From 4e28466880b7c70d29b21300c81ab3dcd1b96478 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Thu, 2 Apr 2020 12:02:00 +0100 Subject: [PATCH] cleanup to minimize diff for RFC FS-1087 --- src/fsharp/IlxGen.fs | 469 ++++++++++++---------- src/fsharp/InnerLambdasToTopLevelFuncs.fs | 10 +- src/fsharp/LowerCallsAndSeqs.fs | 221 +++++----- src/fsharp/LowerCallsAndSeqs.fsi | 4 +- src/fsharp/TypedTree.fs | 107 ++++- src/fsharp/TypedTreeOps.fs | 138 +++---- src/fsharp/TypedTreeOps.fsi | 3 + src/fsharp/range.fs | 10 +- 8 files changed, 553 insertions(+), 409 deletions(-) diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index 75133acef2d..8d16b28c35e 100644 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -812,6 +812,40 @@ and Mark = | Mark of ILCodeLabel member x.CodeLabel = (let (Mark lab) = x in lab) +//-------------------------------------------------------------------------- +// We normally generate in the context of a "what to do next" continuation +//-------------------------------------------------------------------------- + +and sequel = + | EndFilter + + /// Exit a 'handler' block + /// The integer says which local to save result in + | LeaveHandler of (bool (* finally? *) * int * Mark) + + /// Branch to the given mark + | Br of Mark + | CmpThenBrOrContinue of Pops * ILInstr list + + /// Continue and leave the value on the IL computation stack + | Continue + + /// The value then do something else + | DiscardThen of sequel + + /// Return from the method + | Return + + /// End a scope of local variables. Used at end of 'let' and 'let rec' blocks to get tail recursive setting + /// of end-of-scope marks + | EndLocalScope of sequel * Mark + + /// Return from a method whose return type is void + | ReturnVoid + +and Pushes = ILType list +and Pops = int + /// The overall environment at a particular point in an expression tree. and IlxGenEnv = { /// The representation decisions for the (non-erased) type parameters that are in scope @@ -852,6 +886,9 @@ and IlxGenEnv = override __.ToString() = "" +let discard = DiscardThen Continue +let discardAndReturnVoid = DiscardThen ReturnVoid + let SetIsInLoop isInLoop eenv = if eenv.isInLoop = isInLoop then eenv else { eenv with isInLoop = isInLoop } @@ -1613,8 +1650,6 @@ type AssemblyBuilder(cenv: cenv, anonTypeTable: AnonTypeGenerationTable) as mgbu /// Record the types of the things on the evaluation stack. /// Used for the few times we have to flush the IL evaluation stack and to compute maxStack. -type Pushes = ILType list -type Pops = int let pop (i: int) : Pops = i let Push tys: Pushes = tys let Push0 = Push [] @@ -1874,35 +1909,6 @@ let GenConstArray cenv (cgbuf: CodeGenBuffer) eenv ilElementType (data:'a[]) (wr Push0 [ mkNormalCall (mkInitializeArrayMethSpec g) ] - -//-------------------------------------------------------------------------- -// We normally generate in the context of a "what to do next" continuation -//-------------------------------------------------------------------------- - -type sequel = - | EndFilter - /// Exit a 'handler' block - /// The integer says which local to save result in - | LeaveHandler of (bool (* finally? *) * int * Mark) - /// Branch to the given mark - | Br of Mark - | CmpThenBrOrContinue of Pops * ILInstr list - /// Continue and leave the value on the IL computation stack - | Continue - /// The value then do something else - | DiscardThen of sequel - /// Return from the method - | Return - /// End a scope of local variables. Used at end of 'let' and 'let rec' blocks to get tail recursive setting - /// of end-of-scope marks - | EndLocalScope of sequel * Mark - /// Return from a method whose return type is void - | ReturnVoid - -let discard = DiscardThen Continue -let discardAndReturnVoid = DiscardThen ReturnVoid - - //------------------------------------------------------------------------- // This is the main code generation routine. It is used to generate // the bodies of methods in a couple of places @@ -2201,150 +2207,169 @@ and GenExprWithStackGuard cenv cgbuf eenv sp expr sequel = | :? System.InsufficientExecutionStackException -> error(InternalError(sprintf "Expression is too large and/or complex to emit. Method name: '%s'. Recursive depth: %i." cgbuf.MethodName cenv.exprRecursionDepth, expr.Range)) -and GenExprAux (cenv: cenv) (cgbuf: CodeGenBuffer) eenv sp expr sequel = - let g = cenv.g - let expr = stripExpr expr +/// Process the debug point and check for alternative ways to generate this expression. +/// Returns 'true' if the expression was processed by alternative means. +and GenExprPreSteps (cenv: cenv) (cgbuf: CodeGenBuffer) eenv sp expr sequel = + let g = cenv.g - ProcessDebugPointForExpr cenv cgbuf sp expr + ProcessDebugPointForExpr cenv cgbuf sp expr - // A sequence expression will always match Expr.App. - match (if compileSequenceExpressions then LowerCallsAndSeqs.LowerSeqExpr g cenv.amap expr else None) with - | Some info -> - GenSequenceExpr cenv cgbuf eenv info sequel - | None -> + match (if compileSequenceExpressions then LowerCallsAndSeqs.ConvertSequenceExprToObject g cenv.amap expr else None) with + | Some info -> + GenSequenceExpr cenv cgbuf eenv info sequel + true + | None -> + false - match expr with - // 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 - | Expr.Sequential _ - | Expr.Let _ - | LinearOpExpr _ - | Expr.Match _ -> - GenLinearExpr cenv cgbuf eenv sp expr sequel (* canProcessDebugPoint *) false id |> ignore - - | Expr.Const (c, m, ty) -> - GenConstant cenv cgbuf eenv (c, m, ty) sequel - | Expr.LetRec (binds, body, m, _) -> - GenLetRec cenv cgbuf eenv (binds, body, m) sequel - | Expr.Lambda _ | Expr.TyLambda _ -> - GenLambda cenv cgbuf eenv false None expr sequel - | Expr.App (Expr.Val (vref, _, m) as v, _, tyargs, [], _) when - List.forall (isMeasureTy g) tyargs && - ( - // inline only values that are stored in local variables - match StorageForValRef g m vref eenv with - | ValStorage.Local _ -> true - | _ -> false - ) -> - // application of local type functions with type parameters = measure types and body = local value - inline the body - GenExpr cenv cgbuf eenv sp v sequel - | Expr.App (f,fty, tyargs, args, m) -> - GenApp cenv cgbuf eenv (f, fty, tyargs, args, m) sequel - | Expr.Val (v, _, m) -> - GenGetVal cenv cgbuf eenv (v, m) sequel - - | Expr.Op (op, tyargs, args, m) -> - match op, args, tyargs with - | TOp.ExnConstr c, _, _ -> - GenAllocExn cenv cgbuf eenv (c, args, m) sequel - | TOp.UnionCase c, _, _ -> - GenAllocUnionCase cenv cgbuf eenv (c, tyargs, args, m) sequel - | TOp.Recd (isCtor, tycon), _, _ -> - GenAllocRecd cenv cgbuf eenv isCtor (tycon, tyargs, args, m) sequel - | TOp.AnonRecd anonInfo, _, _ -> - GenAllocAnonRecd cenv cgbuf eenv (anonInfo, tyargs, args, m) sequel - | TOp.AnonRecdGet (anonInfo, n), [e], _ -> - GenGetAnonRecdField cenv cgbuf eenv (anonInfo, e, tyargs, n, m) sequel - | TOp.TupleFieldGet (tupInfo, n), [e], _ -> - GenGetTupleField cenv cgbuf eenv (tupInfo, e, tyargs, n, m) sequel - | TOp.ExnFieldGet (ecref, n), [e], _ -> - GenGetExnField cenv cgbuf eenv (e, ecref, n, m) sequel - | TOp.UnionCaseFieldGet (ucref, n), [e], _ -> - GenGetUnionCaseField cenv cgbuf eenv (e, ucref, tyargs, n, m) sequel - | TOp.UnionCaseFieldGetAddr (ucref, n, _readonly), [e], _ -> - GenGetUnionCaseFieldAddr cenv cgbuf eenv (e, ucref, tyargs, n, m) sequel - | TOp.UnionCaseTagGet ucref, [e], _ -> - GenGetUnionCaseTag cenv cgbuf eenv (e, ucref, tyargs, m) sequel - | TOp.UnionCaseProof ucref, [e], _ -> - GenUnionCaseProof cenv cgbuf eenv (e, ucref, tyargs, m) sequel - | TOp.ExnFieldSet (ecref, n), [e;e2], _ -> - GenSetExnField cenv cgbuf eenv (e, ecref, n, e2, m) sequel - | TOp.UnionCaseFieldSet (ucref, n), [e;e2], _ -> - GenSetUnionCaseField cenv cgbuf eenv (e, ucref, tyargs, n, e2, m) sequel - | TOp.ValFieldGet f, [e], _ -> - GenGetRecdField cenv cgbuf eenv (e, f, tyargs, m) sequel - | TOp.ValFieldGet f, [], _ -> - GenGetStaticField cenv cgbuf eenv (f, tyargs, m) sequel - | TOp.ValFieldGetAddr (f, _readonly), [e], _ -> - GenGetRecdFieldAddr cenv cgbuf eenv (e, f, tyargs, m) sequel - | TOp.ValFieldGetAddr (f, _readonly), [], _ -> - GenGetStaticFieldAddr cenv cgbuf eenv (f, tyargs, m) sequel - | TOp.ValFieldSet f, [e1;e2], _ -> - GenSetRecdField cenv cgbuf eenv (e1, f, tyargs, e2, m) sequel - | TOp.ValFieldSet f, [e2], _ -> - GenSetStaticField cenv cgbuf eenv (f, tyargs, e2, m) sequel - | TOp.Tuple tupInfo, _, _ -> - GenAllocTuple cenv cgbuf eenv (tupInfo, args, tyargs, m) sequel - | TOp.ILAsm (code, returnTys), _, _ -> - GenAsmCode cenv cgbuf eenv (code, tyargs, args, returnTys, m) sequel - | TOp.While (sp, _), [Expr.Lambda (_, _, _, [_], e1, _, _);Expr.Lambda (_, _, _, [_], e2, _, _)], [] -> - GenWhileLoop cenv cgbuf eenv (sp, e1, e2, m) sequel - | TOp.For (spStart, dir), [Expr.Lambda (_, _, _, [_], e1, _, _);Expr.Lambda (_, _, _, [_], e2, _, _);Expr.Lambda (_, _, _, [v], e3, _, _)], [] -> - GenForLoop cenv cgbuf eenv (spStart, v, e1, dir, e2, e3, m) sequel - | TOp.TryFinally (spTry, spFinally), [Expr.Lambda (_, _, _, [_], e1, _, _); Expr.Lambda (_, _, _, [_], e2, _, _)], [resty] -> - GenTryFinally cenv cgbuf eenv (e1, e2, m, resty, spTry, spFinally) sequel - | TOp.TryCatch (spTry, spWith), [Expr.Lambda (_, _, _, [_], e1, _, _); Expr.Lambda (_, _, _, [vf], ef, _, _);Expr.Lambda (_, _, _, [vh], eh, _, _)], [resty] -> - GenTryCatch cenv cgbuf eenv (e1, vf, ef, vh, eh, m, resty, spTry, spWith) sequel - | TOp.ILCall (virt, _, valu, newobj, valUseFlags, _, isDllImport, ilMethRef, enclArgTys, methArgTys, returnTys), args, [] -> - GenILCall cenv cgbuf eenv (virt, valu, newobj, valUseFlags, isDllImport, ilMethRef, enclArgTys, methArgTys, args, returnTys, m) sequel - | TOp.RefAddrGet _readonly, [e], [ty] -> GenGetAddrOfRefCellField cenv cgbuf eenv (e, ty, m) sequel - | TOp.Coerce, [e], [tgty;srcty] -> GenCoerce cenv cgbuf eenv (e, tgty, m, srcty) sequel - | TOp.Reraise, [], [rtnty] -> GenReraise cenv cgbuf eenv (rtnty, m) sequel - | TOp.TraitCall ss, args, [] -> GenTraitCall cenv cgbuf eenv (ss, args, m) expr sequel - | TOp.LValueOp (LSet, v), [e], [] -> GenSetVal cenv cgbuf eenv (v, e, m) sequel - | TOp.LValueOp (LByrefGet, v), [], [] -> GenGetByref cenv cgbuf eenv (v, m) sequel - | TOp.LValueOp (LByrefSet, v), [e], [] -> GenSetByref cenv cgbuf eenv (v, e, m) sequel - | TOp.LValueOp (LAddrOf _, v), [], [] -> GenGetValAddr cenv cgbuf eenv (v, m) sequel - | TOp.Array, elems, [elemTy] -> GenNewArray cenv cgbuf eenv (elems, elemTy, m) sequel - | TOp.Bytes bytes, [], [] -> - if cenv.opts.emitConstantArraysUsingStaticDataBlobs then - GenConstArray cenv cgbuf eenv g.ilg.typ_Byte bytes (fun buf b -> buf.EmitByte b) - GenSequel cenv eenv.cloc cgbuf sequel - else - GenNewArraySimple cenv cgbuf eenv (List.ofArray (Array.map (mkByte g m) bytes), g.byte_ty, m) sequel - | TOp.UInt16s arr, [], [] -> - if cenv.opts.emitConstantArraysUsingStaticDataBlobs then - GenConstArray cenv cgbuf eenv g.ilg.typ_UInt16 arr (fun buf b -> buf.EmitUInt16 b) - GenSequel cenv eenv.cloc cgbuf sequel - else - GenNewArraySimple cenv cgbuf eenv (List.ofArray (Array.map (mkUInt16 g m) arr), g.uint16_ty, m) sequel - | TOp.Goto label, _, _ -> - if cgbuf.mgbuf.cenv.opts.generateDebugSymbols then - cgbuf.EmitStartOfHiddenCode() - CG.EmitInstr cgbuf (pop 0) Push0 AI_nop - CG.EmitInstr cgbuf (pop 0) Push0 (I_br label) - // NOTE: discard sequel - | TOp.Return, [e], _ -> - GenExpr cenv cgbuf eenv SPSuppress e Return - // NOTE: discard sequel - | TOp.Return, [], _ -> - GenSequel cenv eenv.cloc cgbuf ReturnVoid - // NOTE: discard sequel - | TOp.Label label, _, _ -> - cgbuf.SetMarkToHere (Mark label) - GenUnitThenSequel cenv eenv m eenv.cloc cgbuf sequel - | _ -> error(InternalError("Unexpected operator node expression", expr.Range)) - | Expr.StaticOptimization (constraints, e2, e3, m) -> - GenStaticOptimization cenv cgbuf eenv (constraints, e2, e3, m) sequel - | Expr.Obj (_, ty, _, _, [meth], [], m) when isDelegateTy g ty -> - GenDelegateExpr cenv cgbuf eenv expr (meth, m) sequel - | Expr.Obj (_, ty, basev, basecall, overrides, interfaceImpls, m) -> - GenObjectExpr cenv cgbuf eenv expr (ty, basev, basecall, overrides, interfaceImpls, m) sequel - - | Expr.Quote (ast, conv, _, m, ty) -> GenQuotation cenv cgbuf eenv (ast, conv, m, ty) sequel - | Expr.Link _ -> failwith "Unexpected reclink" - | Expr.TyChoose (_, _, m) -> error(InternalError("Unexpected Expr.TyChoose", m)) +and GenExprAux (cenv: cenv) (cgbuf: CodeGenBuffer) eenv sp expr sequel = + let g = cenv.g + let expr = stripExpr expr + + // Process the debug point and see if there's a replacement technique to process this expression + if GenExprPreSteps cenv cgbuf eenv sp expr sequel then () else + + match expr with + // 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 + | Expr.Sequential _ + | Expr.Let _ + | LinearOpExpr _ + | Expr.Match _ -> + GenLinearExpr cenv cgbuf eenv sp expr sequel false id |> ignore + + | Expr.Const (c, m, ty) -> + GenConstant cenv cgbuf eenv (c, m, ty) sequel + + | Expr.LetRec (binds, body, m, _) -> + GenLetRec cenv cgbuf eenv (binds, body, m) sequel + + | Expr.Lambda _ | Expr.TyLambda _ -> + GenLambda cenv cgbuf eenv false [] expr sequel + + | Expr.App (Expr.Val (vref, _, m) as v, _, tyargs, [], _) when + List.forall (isMeasureTy g) tyargs && + ( + // inline only values that are stored in local variables + match StorageForValRef g m vref eenv with + | ValStorage.Local _ -> true + | _ -> false + ) -> + // application of local type functions with type parameters = measure types and body = local value - inline the body + GenExpr cenv cgbuf eenv sp v sequel + + | Expr.App (f,fty, tyargs, args, m) -> + GenApp cenv cgbuf eenv (f, fty, tyargs, args, m) sequel + + | Expr.Val (v, _, m) -> + GenGetVal cenv cgbuf eenv (v, m) sequel + + | Expr.Op (op, tyargs, args, m) -> + match op, args, tyargs with + | TOp.ExnConstr c, _, _ -> + GenAllocExn cenv cgbuf eenv (c, args, m) sequel + | TOp.UnionCase c, _, _ -> + GenAllocUnionCase cenv cgbuf eenv (c, tyargs, args, m) sequel + | TOp.Recd (isCtor, tycon), _, _ -> + GenAllocRecd cenv cgbuf eenv isCtor (tycon, tyargs, args, m) sequel + | TOp.AnonRecd anonInfo, _, _ -> + GenAllocAnonRecd cenv cgbuf eenv (anonInfo, tyargs, args, m) sequel + | TOp.AnonRecdGet (anonInfo, n), [e], _ -> + GenGetAnonRecdField cenv cgbuf eenv (anonInfo, e, tyargs, n, m) sequel + | TOp.TupleFieldGet (tupInfo, n), [e], _ -> + GenGetTupleField cenv cgbuf eenv (tupInfo, e, tyargs, n, m) sequel + | TOp.ExnFieldGet (ecref, n), [e], _ -> + GenGetExnField cenv cgbuf eenv (e, ecref, n, m) sequel + | TOp.UnionCaseFieldGet (ucref, n), [e], _ -> + GenGetUnionCaseField cenv cgbuf eenv (e, ucref, tyargs, n, m) sequel + | TOp.UnionCaseFieldGetAddr (ucref, n, _readonly), [e], _ -> + GenGetUnionCaseFieldAddr cenv cgbuf eenv (e, ucref, tyargs, n, m) sequel + | TOp.UnionCaseTagGet ucref, [e], _ -> + GenGetUnionCaseTag cenv cgbuf eenv (e, ucref, tyargs, m) sequel + | TOp.UnionCaseProof ucref, [e], _ -> + GenUnionCaseProof cenv cgbuf eenv (e, ucref, tyargs, m) sequel + | TOp.ExnFieldSet (ecref, n), [e;e2], _ -> + GenSetExnField cenv cgbuf eenv (e, ecref, n, e2, m) sequel + | TOp.UnionCaseFieldSet (ucref, n), [e;e2], _ -> + GenSetUnionCaseField cenv cgbuf eenv (e, ucref, tyargs, n, e2, m) sequel + | TOp.ValFieldGet f, [e], _ -> + GenGetRecdField cenv cgbuf eenv (e, f, tyargs, m) sequel + | TOp.ValFieldGet f, [], _ -> + GenGetStaticField cenv cgbuf eenv (f, tyargs, m) sequel + | TOp.ValFieldGetAddr (f, _readonly), [e], _ -> + GenGetRecdFieldAddr cenv cgbuf eenv (e, f, tyargs, m) sequel + | TOp.ValFieldGetAddr (f, _readonly), [], _ -> + GenGetStaticFieldAddr cenv cgbuf eenv (f, tyargs, m) sequel + | TOp.ValFieldSet f, [e1;e2], _ -> + GenSetRecdField cenv cgbuf eenv (e1, f, tyargs, e2, m) sequel + | TOp.ValFieldSet f, [e2], _ -> + GenSetStaticField cenv cgbuf eenv (f, tyargs, e2, m) sequel + | TOp.Tuple tupInfo, _, _ -> + GenAllocTuple cenv cgbuf eenv (tupInfo, args, tyargs, m) sequel + | TOp.ILAsm (code, returnTys), _, _ -> + GenAsmCode cenv cgbuf eenv (code, tyargs, args, returnTys, m) sequel + | TOp.While (sp, _), [Expr.Lambda (_, _, _, [_], e1, _, _);Expr.Lambda (_, _, _, [_], e2, _, _)], [] -> + GenWhileLoop cenv cgbuf eenv (sp, e1, e2, m) sequel + | TOp.For (spStart, dir), [Expr.Lambda (_, _, _, [_], e1, _, _);Expr.Lambda (_, _, _, [_], e2, _, _);Expr.Lambda (_, _, _, [v], e3, _, _)], [] -> + GenForLoop cenv cgbuf eenv (spStart, v, e1, dir, e2, e3, m) sequel + | TOp.TryFinally (spTry, spFinally), [Expr.Lambda (_, _, _, [_], e1, _, _); Expr.Lambda (_, _, _, [_], e2, _, _)], [resty] -> + GenTryFinally cenv cgbuf eenv (e1, e2, m, resty, spTry, spFinally) sequel + | TOp.TryCatch (spTry, spWith), [Expr.Lambda (_, _, _, [_], e1, _, _); Expr.Lambda (_, _, _, [vf], ef, _, _);Expr.Lambda (_, _, _, [vh], eh, _, _)], [resty] -> + GenTryCatch cenv cgbuf eenv (e1, vf, ef, vh, eh, m, resty, spTry, spWith) sequel + | TOp.ILCall (virt, _, valu, newobj, valUseFlags, _, isDllImport, ilMethRef, enclArgTys, methArgTys, returnTys), args, [] -> + GenILCall cenv cgbuf eenv (virt, valu, newobj, valUseFlags, isDllImport, ilMethRef, enclArgTys, methArgTys, args, returnTys, m) sequel + | TOp.RefAddrGet _readonly, [e], [ty] -> GenGetAddrOfRefCellField cenv cgbuf eenv (e, ty, m) sequel + | TOp.Coerce, [e], [tgty;srcty] -> GenCoerce cenv cgbuf eenv (e, tgty, m, srcty) sequel + | TOp.Reraise, [], [rtnty] -> GenReraise cenv cgbuf eenv (rtnty, m) sequel + | TOp.TraitCall ss, args, [] -> GenTraitCall cenv cgbuf eenv (ss, args, m) expr sequel + | TOp.LValueOp (LSet, v), [e], [] -> GenSetVal cenv cgbuf eenv (v, e, m) sequel + | TOp.LValueOp (LByrefGet, v), [], [] -> GenGetByref cenv cgbuf eenv (v, m) sequel + | TOp.LValueOp (LByrefSet, v), [e], [] -> GenSetByref cenv cgbuf eenv (v, e, m) sequel + | TOp.LValueOp (LAddrOf _, v), [], [] -> GenGetValAddr cenv cgbuf eenv (v, m) sequel + | TOp.Array, elems, [elemTy] -> GenNewArray cenv cgbuf eenv (elems, elemTy, m) sequel + | TOp.Bytes bytes, [], [] -> + if cenv.opts.emitConstantArraysUsingStaticDataBlobs then + GenConstArray cenv cgbuf eenv g.ilg.typ_Byte bytes (fun buf b -> buf.EmitByte b) + GenSequel cenv eenv.cloc cgbuf sequel + else + GenNewArraySimple cenv cgbuf eenv (List.ofArray (Array.map (mkByte g m) bytes), g.byte_ty, m) sequel + | TOp.UInt16s arr, [], [] -> + if cenv.opts.emitConstantArraysUsingStaticDataBlobs then + GenConstArray cenv cgbuf eenv g.ilg.typ_UInt16 arr (fun buf b -> buf.EmitUInt16 b) + GenSequel cenv eenv.cloc cgbuf sequel + else + GenNewArraySimple cenv cgbuf eenv (List.ofArray (Array.map (mkUInt16 g m) arr), g.uint16_ty, m) sequel + | TOp.Goto label, _, _ -> + if cgbuf.mgbuf.cenv.opts.generateDebugSymbols then + cgbuf.EmitStartOfHiddenCode() + CG.EmitInstr cgbuf (pop 0) Push0 AI_nop + CG.EmitInstr cgbuf (pop 0) Push0 (I_br label) + // NOTE: discard sequel + | TOp.Return, [e], _ -> + GenExpr cenv cgbuf eenv SPSuppress e Return + // NOTE: discard sequel + | TOp.Return, [], _ -> + GenSequel cenv eenv.cloc cgbuf ReturnVoid + // NOTE: discard sequel + | TOp.Label label, _, _ -> + cgbuf.SetMarkToHere (Mark label) + GenUnitThenSequel cenv eenv m eenv.cloc cgbuf sequel + | _ -> error(InternalError("Unexpected operator node expression", expr.Range)) + + | Expr.StaticOptimization (constraints, e2, e3, m) -> + GenStaticOptimization cenv cgbuf eenv (constraints, e2, e3, m) sequel + + | Expr.Obj (_, ty, _, _, [meth], [], m) when isDelegateTy g ty -> + GenDelegateExpr cenv cgbuf eenv expr (meth, m) sequel + + | Expr.Obj (_, ty, basev, basecall, overrides, interfaceImpls, m) -> + GenObjectExpr cenv cgbuf eenv expr (ty, basev, basecall, overrides, interfaceImpls, m) sequel + + | Expr.Quote (ast, conv, _, m, ty) -> GenQuotation cenv cgbuf eenv (ast, conv, m, ty) sequel + + | Expr.Link _ -> failwith "Unexpected reclink" + + | Expr.TyChoose (_, _, m) -> error(InternalError("Unexpected Expr.TyChoose", m)) and GenExprs cenv cgbuf eenv es = List.iter (fun e -> GenExpr cenv cgbuf eenv SPSuppress e Continue) es @@ -2557,12 +2582,12 @@ and GenAllocUnionCase cenv cgbuf eenv (c,tyargs,args,m) sequel = GenAllocUnionCaseCore cenv cgbuf eenv (c,tyargs,args.Length,m) GenSequel cenv eenv.cloc cgbuf sequel -and GenLinearExpr cenv cgbuf eenv sp expr sequel canProcessDebugPoint (contf: FakeUnit -> FakeUnit) = +and GenLinearExpr cenv cgbuf eenv sp expr sequel preSteps (contf: FakeUnit -> FakeUnit) = let expr = stripExpr expr match expr with | Expr.Sequential (e1, e2, specialSeqFlag, spSeq, _) -> - if canProcessDebugPoint then - ProcessDebugPointForExpr cenv cgbuf sp expr + // Process the debug point and see if there's a replacement technique to process this expression + if preSteps && GenExprPreSteps cenv cgbuf eenv sp expr sequel then contf Fake else // Compiler generated sequential executions result in suppressions of sequence points on both // left and right of the sequence @@ -2574,7 +2599,7 @@ and GenLinearExpr cenv cgbuf eenv sp expr sequel canProcessDebugPoint (contf: Fa match specialSeqFlag with | NormalSeq -> GenExpr cenv cgbuf eenv spAction e1 discard - GenLinearExpr cenv cgbuf eenv spExpr e2 sequel (* canProcessDebugPoint *) true contf + GenLinearExpr cenv cgbuf eenv spExpr e2 sequel true contf | ThenDoSeq -> GenExpr cenv cgbuf eenv spExpr e1 Continue GenExpr cenv cgbuf eenv spAction e2 discard @@ -2582,8 +2607,8 @@ and GenLinearExpr cenv cgbuf eenv sp expr sequel canProcessDebugPoint (contf: Fa contf Fake | Expr.Let (bind, body, _, _) -> - if canProcessDebugPoint then - ProcessDebugPointForExpr cenv cgbuf sp expr + // Process the debug point and see if there's a replacement technique to process this expression + if preSteps && GenExprPreSteps cenv cgbuf eenv sp expr sequel then contf Fake else // This case implemented here to get a guaranteed tailcall // Make sure we generate the sequence point outside the scope of the variable @@ -2604,11 +2629,11 @@ and GenLinearExpr cenv cgbuf eenv sp expr sequel canProcessDebugPoint (contf: Fa | NoDebugPointAtStickyBinding -> SPSuppress // Generate the body - GenLinearExpr cenv cgbuf eenv spBody body (EndLocalScope(sequel, endScope)) (* canProcessDebugPoint *) true contf + GenLinearExpr cenv cgbuf eenv spBody body (EndLocalScope(sequel, endScope)) true contf | Expr.Match (spBind, _exprm, tree, targets, m, ty) -> - if canProcessDebugPoint then - ProcessDebugPointForExpr cenv cgbuf sp expr + // Process the debug point and see if there's a replacement technique to process this expression + if preSteps && GenExprPreSteps cenv cgbuf eenv sp expr sequel then contf Fake else match spBind with | DebugPointAtBinding m -> CG.EmitSeqPoint cgbuf m @@ -2668,11 +2693,11 @@ and GenLinearExpr cenv cgbuf eenv sp expr sequel canProcessDebugPoint (contf: Fa Fake)) | LinearOpExpr (TOp.UnionCase c, tyargs, argsFront, argLast, m) -> - if canProcessDebugPoint then - ProcessDebugPointForExpr cenv cgbuf sp expr + // Process the debug point and see if there's a replacement technique to process this expression + if preSteps && GenExprPreSteps cenv cgbuf eenv sp expr sequel then contf Fake else GenExprs cenv cgbuf eenv argsFront - GenLinearExpr cenv cgbuf eenv SPSuppress argLast Continue (* canProcessDebugPoint *) true (contf << (fun Fake -> + GenLinearExpr cenv cgbuf eenv SPSuppress argLast Continue true (contf << (fun Fake -> GenAllocUnionCaseCore cenv cgbuf eenv (c, tyargs, argsFront.Length + 1, m) GenSequel cenv eenv.cloc cgbuf sequel Fake)) @@ -4144,7 +4169,7 @@ and GenObjectMethod cenv eenvinner (cgbuf: CodeGenBuffer) useMethodImpl tmethod let g = cenv.g // Check if we're compiling the property as a .NET event - let (TObjExprMethod(slotsig, attribs, methTyparsOfOverridingMethod, methodParams, methodBodyExpr, m)) = tmethod + let (TObjExprMethod(slotsig, attribs, methTyparsOfOverridingMethod, methodParams, moveNextExpr, m)) = tmethod let (TSlotSig(nameOfOverridenMethod, _, _, _, _, _)) = slotsig if CompileAsEvent g attribs then [] @@ -4160,9 +4185,9 @@ and GenObjectMethod cenv eenvinner (cgbuf: CodeGenBuffer) useMethodImpl tmethod // Args are stored starting at #1 let eenvForMeth = AddStorageForLocalVals g (methodParams |> List.mapi (fun i v -> (v, Arg i))) eenvUnderTypars let sequel = (if slotSigHasVoidReturnTy slotsig then discardAndReturnVoid else Return) - let ilMethodBody = CodeGenMethodForExpr cenv cgbuf.mgbuf (SPAlways, [], nameOfOverridenMethod, eenvForMeth, 0, methodBodyExpr, sequel) + let ilMethodBody = CodeGenMethodForExpr cenv cgbuf.mgbuf (SPAlways, [], nameOfOverridenMethod, eenvForMeth, 0, moveNextExpr, sequel) - let nameOfOverridingMethod, methodImplGenerator = GenMethodImpl cenv eenvinner (useMethodImpl, slotsig) methodBodyExpr.Range + let nameOfOverridingMethod, methodImplGenerator = GenMethodImpl cenv eenvinner (useMethodImpl, slotsig) moveNextExpr.Range let mdef = mkILGenericVirtualMethod @@ -4180,7 +4205,7 @@ and GenObjectMethod cenv eenvinner (cgbuf: CodeGenBuffer) useMethodImpl tmethod and GenObjectExpr cenv cgbuf eenvouter expr (baseType, baseValOpt, basecall, overrides, interfaceImpls, m) sequel = let g = cenv.g - let cloinfo, _, eenvinner = GetIlxClosureInfo cenv m false None eenvouter expr + let cloinfo, _, eenvinner = GetIlxClosureInfo cenv m false [] eenvouter expr let cloAttribs = cloinfo.cloAttribs let cloFreeVars = cloinfo.cloFreeVars @@ -4244,7 +4269,7 @@ and GenSequenceExpr // Get the free variables. Make a lambda to pretend that the 'nextEnumeratorValRef' is bound (it is an argument to GenerateNext) let (cloAttribs, _, _, cloFreeTyvars, cloFreeVars, ilCloTypeRef: ILTypeRef, ilCloFreeVars, eenvinner) = - GetIlxClosureFreeVars cenv m None eenvouter [] (mkLambda m nextEnumeratorValRef.Deref (generateNextExpr, g.int32_ty)) + GetIlxClosureFreeVars cenv m [] eenvouter [] (mkLambda m nextEnumeratorValRef.Deref (generateNextExpr, g.int32_ty)) let ilCloSeqElemTy = GenType cenv.amap m eenvinner.tyenv seqElemTy let cloRetTy = mkSeqTy g seqElemTy @@ -4371,18 +4396,15 @@ and GenGenericArgs m (tyenv: TypeReprEnv) tps = tps |> DropErasedTypars |> List.map (fun c -> (mkILTyvarTy tyenv.[c, m])) /// Generate the closure class for a function -and GenLambdaClosure cenv (cgbuf: CodeGenBuffer) eenv isLocalTypeFunc selfv expr = +and GenLambdaClosure cenv (cgbuf: CodeGenBuffer) eenv isLocalTypeFunc thisVars expr = let g = cenv.g match expr with | Expr.Lambda (_, _, _, _, _, m, _) | Expr.TyLambda (_, _, _, m, _) -> - let cloinfo, body, eenvinner = GetIlxClosureInfo cenv m isLocalTypeFunc selfv eenv expr + let cloinfo, body, eenvinner = GetIlxClosureInfo cenv m isLocalTypeFunc thisVars eenv expr - let entryPointInfo = - match selfv with - | Some v -> [(v, BranchCallClosure (cloinfo.cloArityInfo))] - | _ -> [] + let entryPointInfo = thisVars |> List.map (fun v -> (v, BranchCallClosure (cloinfo.cloArityInfo))) let ilCloBody = CodeGenMethodForExpr cenv cgbuf.mgbuf (SPAlways, entryPointInfo, cloinfo.cloName, eenvinner, 1, body, Return) let ilCloTypeRef = cloinfo.cloSpec.TypeRef @@ -4447,8 +4469,8 @@ and GenLambdaVal cenv (cgbuf: CodeGenBuffer) eenv (cloinfo, m) = (Push [EraseClosures.mkTyOfLambdas g.ilxPubCloEnv cloinfo.ilCloLambdas]) (I_newobj (cloinfo.cloSpec.Constructor, None)) -and GenLambda cenv cgbuf eenv isLocalTypeFunc selfv expr sequel = - let cloinfo, m = GenLambdaClosure cenv cgbuf eenv isLocalTypeFunc selfv expr +and GenLambda cenv cgbuf eenv isLocalTypeFunc thisVars expr sequel = + let cloinfo, m = GenLambdaClosure cenv cgbuf eenv isLocalTypeFunc thisVars expr GenLambdaVal cenv cgbuf eenv (cloinfo, m) GenSequel cenv eenv.cloc cgbuf sequel @@ -4466,7 +4488,7 @@ and GenFreevar cenv m eenvouter tyenvinner (fv: Val) = #endif | _ -> GenType cenv.amap m tyenvinner fv.Type -and GetIlxClosureFreeVars cenv m selfv eenvouter takenNames expr = +and GetIlxClosureFreeVars cenv m (thisVars: ValRef list) eenvouter takenNames expr = let g = cenv.g // Choose a base name for the closure @@ -4505,12 +4527,10 @@ and GetIlxClosureFreeVars cenv m selfv eenvouter takenNames expr = cloFreeVarResults.FreeLocals |> Zset.elements |> List.filter (fun fv -> - match StorageForVal cenv.g m fv eenvouter with - | (StaticField _ | StaticProperty _ | Method _ | Null) -> false - | _ -> - match selfv with - | Some v -> not (valRefEq g (mkLocalValRef fv) v) - | _ -> true) + (thisVars |> List.forall (fun v -> not (valRefEq g (mkLocalValRef fv) v))) && + (match StorageForVal cenv.g m fv eenvouter with + | (StaticField _ | StaticProperty _ | Method _ | Null) -> false + | _ -> true)) // The general shape is: // {LAM . expr }[free-typars]: overall-type[contract-typars] @@ -4540,7 +4560,7 @@ and GetIlxClosureFreeVars cenv m selfv eenvouter takenNames expr = // If generating a named closure, add the closure itself as a var, available via "arg0" . // The latter doesn't apply for the delegate implementation of closures. // Build the environment that is active inside the closure itself - let eenvinner = eenvinner |> AddStorageForLocalVals g (match selfv with | Some v -> [(v.Deref, Arg 0)] | _ -> []) + let eenvinner = eenvinner |> AddStorageForLocalVals g (thisVars |> List.map (fun v -> (v.Deref, Arg 0))) let ilCloFreeVars = let ilCloFreeVarNames = ChooseFreeVarNames takenNames (List.map nameOfVal cloFreeVars) @@ -4564,7 +4584,7 @@ and GetIlxClosureFreeVars cenv m selfv eenvouter takenNames expr = (cloAttribs, cloInternalFreeTyvars, cloContractFreeTyvars, cloFreeTyvars, cloFreeVars, ilCloTypeRef, Array.ofList ilCloFreeVars, eenvinner) -and GetIlxClosureInfo cenv m isLocalTypeFunc selfv eenvouter expr = +and GetIlxClosureInfo cenv m isLocalTypeFunc thisVars eenvouter expr = let g = cenv.g let returnTy = match expr with @@ -4591,7 +4611,8 @@ and GetIlxClosureInfo cenv m isLocalTypeFunc selfv eenvouter expr = let takenNames = vs |> List.map (fun v -> v.CompiledName g.CompilerGlobalState) // Get the free variables and the information about the closure, add the free variables to the environment - let (cloAttribs, cloInternalFreeTyvars, cloContractFreeTyvars, _, cloFreeVars, ilCloTypeRef, ilCloFreeVars, eenvinner) = GetIlxClosureFreeVars cenv m selfv eenvouter takenNames expr + let (cloAttribs, cloInternalFreeTyvars, cloContractFreeTyvars, _, cloFreeVars, ilCloTypeRef, ilCloFreeVars, eenvinner) = + GetIlxClosureFreeVars cenv m thisVars eenvouter takenNames expr // Put the type and value arguments into the environment let rec getClosureArgs eenv ntmargs tvsl (vs: Val list) = @@ -4748,7 +4769,8 @@ and GenDelegateExpr cenv cgbuf eenvouter expr (TObjExprMethod((TSlotSig(_, deleg // Work out the free type variables for the morphing thunk let takenNames = List.map nameOfVal tmvs - let (cloAttribs, _, _, cloFreeTyvars, cloFreeVars, ilDelegeeTypeRef, ilCloFreeVars, eenvinner) = GetIlxClosureFreeVars cenv m None eenvouter takenNames expr + let (cloAttribs, _, _, cloFreeTyvars, cloFreeVars, ilDelegeeTypeRef, ilCloFreeVars, eenvinner) = + GetIlxClosureFreeVars cenv m [] eenvouter takenNames expr let ilDelegeeGenericParams = GenGenericParams cenv eenvinner cloFreeTyvars let ilDelegeeGenericActualsInner = mkILFormalGenericArgs 0 ilDelegeeGenericParams @@ -4921,11 +4943,16 @@ and GenDecisionTreeSuccess cenv cgbuf inplabOpt stackAtTargets eenv es targetIdx else match inplabOpt with None -> () | Some inplab -> CG.SetMarkToHere cgbuf inplab repeatSP() - // It would be better not to emit any expressions here, and instead push these assignments into the postponed target - // However not all targets are currently postponed (we only postpone in debug code), pending further testing of the performance - // impact of postponing. - (vs, es) ||> List.iter2 (GenBindingRhs cenv cgbuf eenv SPSuppress) - vs |> List.rev |> List.iter (fun v -> GenStoreVal cenv cgbuf eenvAtTarget v.Range v) + + (vs, es) ||> List.iter2 (fun v e -> + + // Emit the expression + GenBindingRhs cenv cgbuf eenv SPSuppress v e) + + vs |> List.rev |> List.iter (fun v -> + // Store the results + GenStoreVal cenv cgbuf eenvAtTarget v.Range v) + CG.EmitInstr cgbuf (pop 0) Push0 (I_br targetMarkAfterBinds.CodeLabel) targetInfos, None @@ -5188,12 +5215,12 @@ and GenLetRecBindings cenv (cgbuf: CodeGenBuffer) eenv (allBinds: Bindings, m) = | Null -> false | _ -> true) - let computeFixupsForOneRecursiveVar boundv forwardReferenceSet fixups selfv access set e = + let computeFixupsForOneRecursiveVar boundv forwardReferenceSet fixups thisVars access set e = match e with | Expr.Lambda _ | Expr.TyLambda _ | Expr.Obj _ -> - let isLocalTypeFunc = Option.isSome selfv && (IsNamedLocalTypeFuncVal cenv.g (Option.get selfv) e) - let selfv = (match e with Expr.Obj _ -> None | _ when isLocalTypeFunc -> None | _ -> Option.map mkLocalValRef selfv) - let clo, _, eenvclo = GetIlxClosureInfo cenv m isLocalTypeFunc selfv {eenv with letBoundVars=(mkLocalValRef boundv) :: eenv.letBoundVars} e + let isLocalTypeFunc = Option.isSome thisVars && (IsNamedLocalTypeFuncVal cenv.g (Option.get thisVars) e) + let thisVars = (match e with Expr.Obj _ -> [] | _ when isLocalTypeFunc -> [] | _ -> Option.map mkLocalValRef thisVars |> Option.toList) + let clo, _, eenvclo = GetIlxClosureInfo cenv m isLocalTypeFunc thisVars {eenv with letBoundVars=(mkLocalValRef boundv) :: eenv.letBoundVars} e clo.cloFreeVars |> List.iter (fun fv -> if Zset.contains fv forwardReferenceSet then match StorageForVal cenv.g m fv eenvclo with @@ -6051,8 +6078,8 @@ and GenBindingRhs cenv cgbuf eenv sp (vspec: Val) e = // type lambda with erased type arguments that is stored as local variable (not method or property)- inline body GenExpr cenv cgbuf eenv sp body Continue | _ -> - let selfv = if isLocalTypeFunc then None else Some (mkLocalValRef vspec) - GenLambda cenv cgbuf eenv isLocalTypeFunc selfv e Continue + let thisVars = if isLocalTypeFunc then [] else [ mkLocalValRef vspec ] + GenLambda cenv cgbuf eenv isLocalTypeFunc thisVars e Continue | _ -> GenExpr cenv cgbuf eenv sp e Continue @@ -6142,7 +6169,7 @@ and GenGetStorageAndSequel cenv cgbuf eenv m (ty, ilTy) storage storeSequel = // Then reduce out any arguments (i.e. apply the sequel immediately if we can...) match storeSequel with | None -> - GenLambda cenv cgbuf eenv false None expr Continue + GenLambda cenv cgbuf eenv false [] expr Continue | Some (tyargs', args, m, sequel) -> let specializedExpr = if isNil args && isNil tyargs' then failwith ("non-lambda at use of method " + mspec.Name) @@ -6200,7 +6227,7 @@ and AllocLocalVal cenv cgbuf v eenv repr scopeMarks = let eenvinner = {eenv with letBoundVars=(mkLocalValRef v) :: eenv.letBoundVars} - let cloinfo, _, _ = GetIlxClosureInfo cenv v.Range true None eenvinner (Option.get repr) + let cloinfo, _, _ = GetIlxClosureInfo cenv v.Range true [] eenvinner (Option.get repr) cloinfo let idx, realloc, eenv = AllocLocal cenv cgbuf eenv v.IsCompilerGenerated (v.CompiledName g.CompilerGlobalState, g.ilg.typ_Object, false) scopeMarks diff --git a/src/fsharp/InnerLambdasToTopLevelFuncs.fs b/src/fsharp/InnerLambdasToTopLevelFuncs.fs index 8de9b0ad2db..b21f0d22790 100644 --- a/src/fsharp/InnerLambdasToTopLevelFuncs.fs +++ b/src/fsharp/InnerLambdasToTopLevelFuncs.fs @@ -1129,12 +1129,12 @@ module Pass4_RewriteAssembly = // ilobj - has implicit lambda exprs and recursive/base references | Expr.Obj (_, ty, basev, basecall, overrides, iimpls, m) -> - let basecall, z = TransExpr penv z basecall - let overrides, z = List.mapFold (TransMethod penv) z overrides - let (iimpls:(TType*ObjExprMethod list)list), (z: RewriteState) = - List.mapFold (fun z (tType, objExprs) -> + let basecall, z = TransExpr penv z basecall + let overrides, z = List.mapFold (TransMethod penv) z overrides + let iimpls, z = + (z, iimpls) ||> List.mapFold (fun z (tType, objExprs) -> let objExprs', z' = List.mapFold (TransMethod penv) z objExprs - (tType, objExprs'), z') z iimpls + (tType, objExprs'), z') let expr = Expr.Obj (newUnique(), ty, basev, basecall, overrides, iimpls, m) let pds, z = ExtractPreDecs z MakePreDecs m pds expr, z (* if TopLevel, lift preDecs over the ilobj expr *) diff --git a/src/fsharp/LowerCallsAndSeqs.fs b/src/fsharp/LowerCallsAndSeqs.fs index 4947bf2bc37..c36f5313de8 100644 --- a/src/fsharp/LowerCallsAndSeqs.fs +++ b/src/fsharp/LowerCallsAndSeqs.fs @@ -59,7 +59,36 @@ let LowerImplFile g assembly = //---------------------------------------------------------------------------- -// State machine compilation for sequence expressions +// General helpers + +let (|WhileExpr|_|) expr = + match expr with + | Expr.Op (TOp.While (sp1, sp2), _, [Expr.Lambda (_, _, _, [_gv], guardExpr, _, _);Expr.Lambda (_, _, _, [_bv], bodyExpr, _, _)], m) -> + Some (sp1, sp2, guardExpr, bodyExpr, m) + | _ -> None + +let (|TryFinallyExpr|_|) expr = + match expr with + | Expr.Op (TOp.TryFinally (sp1, sp2), [ty], [Expr.Lambda (_, _, _, [_], e1, _, _); Expr.Lambda (_, _, _, [_], e2, _, _)], m) -> + Some (sp1, sp2, ty, e1, e2, m) + | _ -> None + +let (|ForLoopExpr|_|) expr = + match expr with + | Expr.Op (TOp.For (sp1, sp2), _, [Expr.Lambda (_, _, _, [_], e1, _, _);Expr.Lambda (_, _, _, [_], e2, _, _);Expr.Lambda (_, _, _, [v], e3, _, _)], m) -> + Some (sp1, sp2, e1, e2, v, e3, m) + | _ -> None + +let (|TryCatchExpr|_|) expr = + match expr with + | Expr.Op (TOp.TryCatch (spTry, spWith), [resTy], [Expr.Lambda (_, _, _, [_], bodyExpr, _, _); Expr.Lambda (_, _, _, [filterVar], filterExpr, _, _); Expr.Lambda (_, _, _, [handlerVar], handlerExpr, _, _)], m) -> + Some (spTry, spWith, resTy, bodyExpr, filterVar, filterExpr, handlerVar, handlerExpr, m) + | _ -> None + +let mkCompGenSequentials m exprs = + List.reduceBack (mkCompGenSequential m) exprs + +let mkLabelled m l e = mkCompGenSequential m (Expr.Op (TOp.Label l, [], [], m)) e let mkLambdaNoType g m uv e = mkLambda m uv (e, tyOfExpr g e) @@ -74,6 +103,8 @@ let callNonOverloadedMethod g amap m methName ty args = | _ -> error(InternalError("The method called '"+methName+"' resolved to a non-IL type", m)) +//---------------------------------------------------------------------------- +// State machine compilation for sequence expressions type LoweredSeqFirstPhaseResult = { @@ -92,7 +123,7 @@ type LoweredSeqFirstPhaseResult = phase2 : ((* pc: *) ValRef * (* current: *) ValRef * (* nextVar: *) ValRef * Map -> Expr * Expr * Expr) /// The labels allocated for one portion of the sequence expression - labels : int list + entryPoints : int list /// Indicates if any actual work is done in dispose, i.e. is there a 'try-finally' (or 'use') in the computation. significantClose : bool @@ -101,11 +132,20 @@ type LoweredSeqFirstPhaseResult = stateVars: ValRef list /// The vars captured by the non-synchronous path - capturedVars: FreeVars + asyncVars: FreeVars } let isVarFreeInExpr v e = Zset.contains v (freeInExpr CollectTyparsAndLocals e).FreeLocals +let (|Seq|_|) g expr = + match expr with + // use 'seq { ... }' as an indicator + | ValApp g g.seq_vref ([elemTy], [e], _m) -> Some (e, elemTy) + | _ -> None + +let IsPossibleSequenceExpr g expr = + match expr with Seq g _ -> true | _ -> false + /// Analyze a TAST expression to detect the elaborated form of a sequence expression. /// Then compile it to a state machine represented as a TAST containing goto, return and label nodes. /// The returned state machine will also contain references to state variables (from internal 'let' bindings), @@ -116,46 +156,39 @@ let isVarFreeInExpr v e = Zset.contains v (freeInExpr CollectTyparsAndLocals e). /// The analysis is done in two phases. The first phase determines the state variables and state labels (as Abstract IL code labels). /// We then allocate an integer pc for each state label and proceed with the second phase, which builds two related state machine /// expressions: one for 'MoveNext' and one for 'Dispose'. -let LowerSeqExpr g amap overallExpr = +let ConvertSequenceExprToObject g amap overallExpr = /// Detect a 'yield x' within a 'seq { ... }' let (|SeqYield|_|) expr = match expr with - | Expr.App (Expr.Val (vref, _, _), _f0ty, _tyargsl, [arg], m) when valRefEq g vref g.seq_singleton_vref -> - Some (arg, m) - | _ -> - None + | ValApp g g.seq_singleton_vref (_, [arg], m) -> Some (arg, m) + | _ -> None /// Detect a 'expr; expr' within a 'seq { ... }' let (|SeqAppend|_|) expr = match expr with - | Expr.App (Expr.Val (vref, _, _), _f0ty, _tyargsl, [arg1;arg2], m) when valRefEq g vref g.seq_append_vref -> - Some (arg1, arg2, m) - | _ -> - None + | ValApp g g.seq_append_vref (_, [arg1; arg2], m) -> Some (arg1, arg2, m) + | _ -> None /// Detect a 'while gd do expr' within a 'seq { ... }' let (|SeqWhile|_|) expr = match expr with - | Expr.App (Expr.Val (vref, _, _), _f0ty, _tyargsl, [Expr.Lambda (_, _, _, [dummyv], gd, _, _);arg2], m) - when valRefEq g vref g.seq_generated_vref && - not (isVarFreeInExpr dummyv gd) -> + | ValApp g g.seq_generated_vref (_, [Expr.Lambda (_, _, _, [dummyv], gd, _, _);arg2], m) + when not (isVarFreeInExpr dummyv gd) -> Some (gd, arg2, m) | _ -> None let (|SeqTryFinally|_|) expr = match expr with - | Expr.App (Expr.Val (vref, _, _), _f0ty, _tyargsl, [arg1;Expr.Lambda (_, _, _, [dummyv], compensation, _, _)], m) - when valRefEq g vref g.seq_finally_vref && - not (isVarFreeInExpr dummyv compensation) -> + | ValApp g g.seq_finally_vref (_, [arg1;Expr.Lambda (_, _, _, [dummyv], compensation, _, _)], m) + when not (isVarFreeInExpr dummyv compensation) -> Some (arg1, compensation, m) | _ -> None let (|SeqUsing|_|) expr = match expr with - | Expr.App (Expr.Val (vref, _, _), _f0ty, [_;_;elemTy], [resource;Expr.Lambda (_, _, _, [v], body, _, _)], m) - when valRefEq g vref g.seq_using_vref -> + | ValApp g g.seq_using_vref ([_;_;elemTy], [resource;Expr.Lambda (_, _, _, [v], body, _, _)], m) -> Some (resource, v, body, elemTy, m) | _ -> None @@ -163,32 +196,30 @@ let LowerSeqExpr g amap overallExpr = let (|SeqFor|_|) expr = match expr with // Nested for loops are represented by calls to Seq.collect - | Expr.App (Expr.Val (vref, _, _), _f0ty, [_inpElemTy;_enumty2;genElemTy], [Expr.Lambda (_, _, _, [v], body, _, _); inp], m) when valRefEq g vref g.seq_collect_vref -> + | ValApp g g.seq_collect_vref ([_inpElemTy;_enumty2;genElemTy], [Expr.Lambda (_, _, _, [v], body, _, _); inp], m) -> Some (inp, v, body, genElemTy, m) // "for x in e -> e2" is converted to a call to Seq.map by the F# type checker. This could be removed, except it is also visible in F# quotations. - | Expr.App (Expr.Val (vref, _, _), _f0ty, [_inpElemTy;genElemTy], [Expr.Lambda (_, _, _, [v], body, _, _); inp], m) when valRefEq g vref g.seq_map_vref -> + | ValApp g g.seq_map_vref ([_inpElemTy;genElemTy], [Expr.Lambda (_, _, _, [v], body, _, _); inp], m) -> Some (inp, v, mkCallSeqSingleton g body.Range genElemTy body, genElemTy, m) | _ -> None let (|SeqDelay|_|) expr = match expr with - | Expr.App (Expr.Val (vref, _, _), _f0ty, [elemTy], [Expr.Lambda (_, _, _, [v], e, _, _)], _m) when valRefEq g vref g.seq_delay_vref && not (isVarFreeInExpr v e) -> Some (e, elemTy) + | ValApp g g.seq_delay_vref ([elemTy], [Expr.Lambda (_, _, _, [v], e, _, _)], _m) + when not (isVarFreeInExpr v e) -> + Some (e, elemTy) | _ -> None let (|SeqEmpty|_|) expr = match expr with - | Expr.App (Expr.Val (vref, _, _), _f0ty, _tyargsl, [], m) when valRefEq g vref g.seq_empty_vref -> Some (m) - | _ -> None - - let (|Seq|_|) expr = - match expr with - // use 'seq { ... }' as an indicator - | Expr.App (Expr.Val (vref, _, _), _f0ty, [elemTy], [e], _m) when valRefEq g vref g.seq_vref -> Some (e, elemTy) + | ValApp g g.seq_empty_vref (_, [], m) -> Some (m) | _ -> None /// Implement a decision to represent a 'let' binding as a non-escaping local variable (rather than a state machine variable) let RepresentBindingAsLocal (bind: Binding) res2 m = - // printfn "LowerSeq: found local variable %s" bind.Var.DisplayName + if verbose then + printfn "LowerSeq: found local variable %s" bind.Var.DisplayName + { res2 with phase2 = (fun ctxt -> let generate2, dispose2, checkDispose2 = res2.phase2 ctxt @@ -200,7 +231,9 @@ let LowerSeqExpr g amap overallExpr = /// Implement a decision to represent a 'let' binding as a state machine variable let RepresentBindingAsStateMachineLocal (bind: Binding) res2 m = - // printfn "LowerSeq: found state variable %s" bind.Var.DisplayName + if verbose then + printfn "LowerSeq: found state variable %s" bind.Var.DisplayName + let (TBind(v, e, sp)) = bind let sp, spm = match sp with @@ -223,7 +256,9 @@ let LowerSeqExpr g amap overallExpr = stateVars = vref :: res2.stateVars } let RepresentBindingsAsLifted mkBinds res2 = - // printfn "found top level let " + if verbose then + printfn "found top level let " + { res2 with phase2 = (fun ctxt -> let generate2, dispose2, checkDispose2 = res2.phase2 ctxt @@ -232,7 +267,7 @@ let LowerSeqExpr g amap overallExpr = let checkDispose = checkDispose2 generate, dispose, checkDispose) } - let rec Lower + let rec ConvertSeqExprCode isWholeExpr isTailCall // is this sequence in tailcall position? noDisposeContinuationLabel // represents the label for the code where there is effectively nothing to do to dispose the iterator for the current state @@ -265,30 +300,30 @@ let LowerSeqExpr g amap overallExpr = (Expr.Op (TOp.Label label, [], [], m)) (Expr.Op (TOp.Return, [], [mkBool g m (not (noDisposeContinuationLabel = currentDisposeContinuationLabel))], m)) generate, dispose, checkDispose) - labels=[label] + entryPoints=[label] stateVars=[] significantClose = false - capturedVars = emptyFreeVars + asyncVars = emptyFreeVars } | SeqDelay(delayedExpr, _elemTy) -> // printfn "found Seq.delay" // note, using 'isWholeExpr' here prevents 'seq { yield! e }' and 'seq { 0 .. 1000 }' from being compiled - Lower isWholeExpr isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel delayedExpr + ConvertSeqExprCode isWholeExpr isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel delayedExpr | SeqAppend(e1, e2, m) -> // printfn "found Seq.append" - let res1 = Lower false false noDisposeContinuationLabel currentDisposeContinuationLabel e1 - let res2 = Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel e2 + let res1 = ConvertSeqExprCode false false noDisposeContinuationLabel currentDisposeContinuationLabel e1 + let res2 = ConvertSeqExprCode false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel e2 match res1, res2 with | Some res1, Some res2 -> - let capturedVars = - if res1.labels.IsEmpty then - res2.capturedVars + let asyncVars = + if res1.entryPoints.IsEmpty then + res2.asyncVars else // All of 'e2' is needed after resuming at any of the labels - unionFreeVars res1.capturedVars (freeInExpr CollectLocals e2) + unionFreeVars res1.asyncVars (freeInExpr CollectLocals e2) Some { phase2 = (fun ctxt -> let generate1, dispose1, checkDispose1 = res1.phase2 ctxt @@ -299,21 +334,21 @@ let LowerSeqExpr g amap overallExpr = let dispose = mkCompGenSequential m dispose2 dispose1 let checkDispose = mkCompGenSequential m checkDispose2 checkDispose1 generate, dispose, checkDispose) - labels= res1.labels @ res2.labels + entryPoints= res1.entryPoints @ res2.entryPoints stateVars = res1.stateVars @ res2.stateVars significantClose = res1.significantClose || res2.significantClose - capturedVars = capturedVars } + asyncVars = asyncVars } | _ -> None | SeqWhile(guardExpr, bodyExpr, m) -> // printfn "found Seq.while" - let resBody = Lower false false noDisposeContinuationLabel currentDisposeContinuationLabel bodyExpr + let resBody = ConvertSeqExprCode false false noDisposeContinuationLabel currentDisposeContinuationLabel bodyExpr match resBody with | Some res2 -> - let capturedVars = - if res2.labels.IsEmpty then - res2.capturedVars // the whole loopis synchronous, no labels + let asyncVars = + if res2.entryPoints.IsEmpty then + res2.asyncVars // the whole loopis synchronous, no labels else freeInExpr CollectLocals expr // everything is needed on subsequent iterations @@ -323,10 +358,10 @@ let LowerSeqExpr g amap overallExpr = let dispose = dispose2 let checkDispose = checkDispose2 generate, dispose, checkDispose) - labels = res2.labels + entryPoints = res2.entryPoints stateVars = res2.stateVars significantClose = res2.significantClose - capturedVars = capturedVars } + asyncVars = asyncVars } | _ -> None @@ -337,7 +372,7 @@ let LowerSeqExpr g amap overallExpr = (mkCallSeqFinally g m elemTy body (mkUnitDelayLambda g m (mkCallDispose g m v.Type (exprForVal m v)))) - Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel reduction + ConvertSeqExprCode false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel reduction | SeqFor(inp, v, body, genElemTy, m) -> // printfn "found Seq.for" @@ -354,15 +389,15 @@ let LowerSeqExpr g amap overallExpr = (mkCallSeqGenerated g m genElemTy (mkUnitDelayLambda g m (callNonOverloadedMethod g amap m "MoveNext" inpEnumTy [enume])) (mkInvisibleLet m v (callNonOverloadedMethod g amap m "get_Current" inpEnumTy [enume]) (mkCoerceIfNeeded g (mkSeqTy g genElemTy) (tyOfExpr g body) body)))) - Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel reduction + ConvertSeqExprCode false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel reduction | SeqTryFinally(e1, compensation, m) -> // printfn "found Seq.try/finally" let innerDisposeContinuationLabel = IL.generateCodeLabel() - let resBody = Lower false false noDisposeContinuationLabel innerDisposeContinuationLabel e1 + let resBody = ConvertSeqExprCode false false noDisposeContinuationLabel innerDisposeContinuationLabel e1 match resBody with | Some res1 -> - let capturedVars = unionFreeVars res1.capturedVars (freeInExpr CollectLocals compensation) + let asyncVars = unionFreeVars res1.asyncVars (freeInExpr CollectLocals compensation) Some { phase2 = (fun ((pcVar, _currv, _, pcMap) as ctxt) -> let generate1, dispose1, checkDispose1 = res1.phase2 ctxt let generate = @@ -374,8 +409,7 @@ let LowerSeqExpr g amap overallExpr = (mkValSet m pcVar (mkInt32 g m pcMap.[innerDisposeContinuationLabel])) generate1 ) // set the PC past the try/finally before trying to run it, to make sure we only run it once - (mkCompGenSequential m - (Expr.Op (TOp.Label innerDisposeContinuationLabel, [], [], m)) + (mkLabelled m innerDisposeContinuationLabel (mkCompGenSequential m (mkValSet m pcVar (mkInt32 g m pcMap.[currentDisposeContinuationLabel])) compensation)) @@ -384,8 +418,7 @@ let LowerSeqExpr g amap overallExpr = mkCompGenSequential m dispose1 // set the PC past the try/finally before trying to run it, to make sure we only run it once - (mkCompGenSequential m - (Expr.Op (TOp.Label innerDisposeContinuationLabel, [], [], m)) + (mkLabelled m innerDisposeContinuationLabel (mkCompGenSequential m (mkValSet m pcVar (mkInt32 g m pcMap.[currentDisposeContinuationLabel])) (mkCompGenSequential m @@ -394,15 +427,14 @@ let LowerSeqExpr g amap overallExpr = let checkDispose = mkCompGenSequential m checkDispose1 - (mkCompGenSequential m - (Expr.Op (TOp.Label innerDisposeContinuationLabel, [], [], m)) + (mkLabelled m innerDisposeContinuationLabel (Expr.Op (TOp.Return, [], [mkTrue g m (* yes, we must dispose!!! *) ], m))) generate, dispose, checkDispose) - labels = innerDisposeContinuationLabel :: res1.labels + entryPoints = innerDisposeContinuationLabel :: res1.entryPoints stateVars = res1.stateVars significantClose = true - capturedVars = capturedVars } + asyncVars = asyncVars } | _ -> None @@ -413,13 +445,13 @@ let LowerSeqExpr g amap overallExpr = let dispose = Expr.Op (TOp.Goto currentDisposeContinuationLabel, [], [], m) let checkDispose = Expr.Op (TOp.Goto currentDisposeContinuationLabel, [], [], m) generate, dispose, checkDispose) - labels = [] + entryPoints = [] stateVars = [] significantClose = false - capturedVars = emptyFreeVars } + asyncVars = emptyFreeVars } | Expr.Sequential (x1, x2, NormalSeq, ty, m) -> - match Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel x2 with + match ConvertSeqExprCode false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel x2 with | Some res2-> // printfn "found sequential execution" Some { res2 with @@ -435,12 +467,12 @@ let LowerSeqExpr g amap overallExpr = // Restriction: compilation of sequence expressions containing non-toplevel constrained generic functions is not supported when bind.Var.IsCompiledAsTopLevel || not (IsGenericValWithGenericConstraints g bind.Var) -> - let resBody = Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel bodyExpr + let resBody = ConvertSeqExprCode false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel bodyExpr match resBody with | Some res2 -> if bind.Var.IsCompiledAsTopLevel then Some (RepresentBindingsAsLifted (mkLetBind m bind) res2) - elif not (res2.capturedVars.FreeLocals.Contains(bind.Var)) then + elif not (res2.asyncVars.FreeLocals.Contains(bind.Var)) then // printfn "found state variable %s" bind.Var.DisplayName Some (RepresentBindingAsLocal bind res2 m) else @@ -458,7 +490,7 @@ let LowerSeqExpr g amap overallExpr = // Rule 1 - IsCompiledAsTopLevel require no state local value bind.Var.IsCompiledAsTopLevel || // Rule 2 - funky constrained local funcs not allowed - not (IsGenericValWithGenericContraints g bind.Var)) && + not (IsGenericValWithGenericConstraints g bind.Var)) && binds |> List.count (fun bind -> // Rule 3 - Recursive non-lambda and repack values are allowed match stripExpr bind.Expr with @@ -468,7 +500,7 @@ let LowerSeqExpr g amap overallExpr = | Expr.Val (v, _, _) when not (recvars.ContainsVal v.Deref) -> false | _ -> true) <= 1) -> - match Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel e2 with + match ConvertSeqExprCode false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel e2 with | Some res2 -> let topLevelBinds, nonTopLevelBinds = binds |> List.partition (fun bind -> bind.Var.IsCompiledAsTopLevel) // Represent the closure-capturing values as state machine locals. They may still be recursively-referential @@ -479,22 +511,29 @@ let LowerSeqExpr g amap overallExpr = | None -> None *) + // LIMITATION: non-trivial pattern matches involving or-patterns or active patterns where bindings can't be + // transferred to the r.h.s. are not yet compiled. + // + // TODO: remove this limitation | Expr.Match (spBind, exprm, pt, targets, m, ty) when targets |> Array.forall (fun (TTarget(vs, _e, _spTarget)) -> isNil vs) -> // lower all the targets. abandon if any fail to lower - let tglArray = targets |> Array.map (fun (TTarget(_vs, targetExpr, _spTarget)) -> Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel targetExpr) - // LIMITATION: non-trivial pattern matches involving or-patterns or active patterns where bindings can't be - // transferred to the r.h.s. are not yet compiled. + // lower all the targets. abandon if any fail to lower + let tglArray = targets |> Array.map (fun (TTarget(_vs, targetExpr, _spTarget)) -> ConvertSeqExprCode false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel targetExpr) if tglArray |> Array.forall Option.isSome then let tglArray = Array.map Option.get tglArray let tgl = Array.toList tglArray - let labs = tgl |> List.collect (fun res -> res.labels) - let (capturedVars, _) = + let labs = tgl |> List.collect (fun res -> res.entryPoints) + + let (asyncVars, _) = ((emptyFreeVars, false), Array.zip targets tglArray) ||> Array.fold (fun (fvs, seenLabel) ((TTarget(_vs, e, _spTarget)), res) -> if seenLabel then unionFreeVars fvs (freeInExpr CollectLocals e), true - else res.capturedVars, not res.labels.IsEmpty) + else res.asyncVars, not res.entryPoints.IsEmpty) + let stateVars = tgl |> List.collect (fun res -> res.stateVars) + let significantClose = tgl |> List.exists (fun res -> res.significantClose) + Some { phase2 = (fun ctxt -> let gtgs, disposals, checkDisposes = (Array.toList targets, tgl) @@ -507,10 +546,10 @@ let LowerSeqExpr g amap overallExpr = let dispose = if isNil disposals then mkUnit g m else List.reduce (mkCompGenSequential m) disposals let checkDispose = if isNil checkDisposes then mkFalse g m else List.reduce (mkCompGenSequential m) checkDisposes generate, dispose, checkDispose) - labels=labs + entryPoints=labs stateVars = stateVars significantClose = significantClose - capturedVars = capturedVars } + asyncVars = asyncVars } else None @@ -567,28 +606,28 @@ let LowerSeqExpr g amap overallExpr = (Expr.Op (TOp.Label label, [], [], m)) (Expr.Op (TOp.Return, [], [mkFalse g m], m)) generate, dispose, checkDispose) - labels=[label] + entryPoints=[label] stateVars=[] significantClose = false - capturedVars = emptyFreeVars } + asyncVars = emptyFreeVars } else let v, ve = mkCompGenLocal m "v" inpElemTy - Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel (mkCallSeqCollect g m inpElemTy inpElemTy (mkLambdaNoType g m v (mkCallSeqSingleton g m inpElemTy ve)) arbitrarySeqExpr) + ConvertSeqExprCode false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel (mkCallSeqCollect g m inpElemTy inpElemTy (mkLambdaNoType g m v (mkCallSeqSingleton g m inpElemTy ve)) arbitrarySeqExpr) match overallExpr with - | Seq(e, ty) -> + | Seq g (e, ty) -> // printfn "found seq { ... } or Seq.delay (fun () -> ...) in FSharp.Core.dll" let m = e.Range let initLabel = IL.generateCodeLabel() let noDisposeContinuationLabel = IL.generateCodeLabel() // Perform phase1 - match Lower true true noDisposeContinuationLabel noDisposeContinuationLabel e with + match ConvertSeqExprCode true true noDisposeContinuationLabel noDisposeContinuationLabel e with | Some res -> // After phase1, create the variables for the state machine and work out a program counter for each label. - let labs = res.labels + let labs = res.entryPoints let stateVars = res.stateVars // printfn "successfully lowered, found %d state variables and %d labels!" stateVars.Length labs.Length let pcVar, pcExpr = mkMutableCompGenLocal m "pc" g.int32_ty @@ -619,8 +658,7 @@ let LowerSeqExpr g amap overallExpr = (mkCompGenSequential m // set the pc to "finished" (mkValSet m pcVarRef (mkInt32 g m pcDone)) - (mkCompGenSequential m - (Expr.Op (TOp.Label noDisposeContinuationLabel, [], [], m)) + (mkLabelled m noDisposeContinuationLabel (mkCompGenSequential m // zero out the current value to free up its memory (mkValSet m currVarRef (mkDefault (m, currVarRef.Type))) @@ -633,8 +671,7 @@ let LowerSeqExpr g amap overallExpr = let checkDisposeExprWithCleanup = mkCompGenSequential m checkDisposeExprCore - (mkCompGenSequential m - (Expr.Op (TOp.Label noDisposeContinuationLabel, [], [], m)) + (mkLabelled m noDisposeContinuationLabel (Expr.Op (TOp.Return, [], [mkFalse g m], m))) // A utility to add a jump table to the three generated methods @@ -658,7 +695,7 @@ let LowerSeqExpr g amap overallExpr = m) let table = mbuilder.Close(dtree, m, g.int_ty) - mkCompGenSequential m table (mkCompGenSequential m (Expr.Op (TOp.Label initLabel, [], [], m)) expr) + mkCompGenSequential m table (mkLabelled m initLabel expr) // A utility to handle the cases where exceptions are raised by the disposal logic. // We wrap the disposal state machine in a loop that repeatedly drives the disposal logic of the @@ -714,8 +751,7 @@ let LowerSeqExpr g amap overallExpr = Some (addResultTarget (mkUnit g m)), m) let pcIsEndStateComparison = mbuilder.Close(dtree, m, g.unit_ty) - mkCompGenSequential m - (Expr.Op ((TOp.Label startLabel), [], [], m)) + mkLabelled m startLabel (mkCompGenSequential m pcIsEndStateComparison (mkCompGenSequential m @@ -747,8 +783,7 @@ let LowerSeqExpr g amap overallExpr = let disposalExpr = mkCompGenSequential m disposalExprCore - (mkCompGenSequential m - (Expr.Op (TOp.Label noDisposeContinuationLabel, [], [], m)) + (mkLabelled m noDisposeContinuationLabel (mkCompGenSequential m // set the pc to "finished" (mkValSet m pcVarRef (mkInt32 g m pcDone)) diff --git a/src/fsharp/LowerCallsAndSeqs.fsi b/src/fsharp/LowerCallsAndSeqs.fsi index 6ff494ceee0..16989637e2b 100644 --- a/src/fsharp/LowerCallsAndSeqs.fsi +++ b/src/fsharp/LowerCallsAndSeqs.fsi @@ -19,4 +19,6 @@ val LowerImplFile: g: TcGlobals -> assembly: TypedImplFile -> TypedImplFile /// a program counter (pc) that records the current state, and a current generated value (current). /// All these variables are then represented as fields in a hosting closure object along with any additional /// free variables of the sequence expression. -val LowerSeqExpr: g: TcGlobals -> amap: ImportMap -> overallExpr: Expr -> (ValRef * ValRef * ValRef * ValRef list * Expr * Expr * Expr * TType * range) option +val ConvertSequenceExprToObject: g: TcGlobals -> amap: ImportMap -> overallExpr: Expr -> (ValRef * ValRef * ValRef * ValRef list * Expr * Expr * Expr * TType * range) option + +val IsPossibleSequenceExpr: g: TcGlobals -> overallExpr: Expr -> bool diff --git a/src/fsharp/TypedTree.fs b/src/fsharp/TypedTree.fs index a8a18820707..8b12eb84295 100644 --- a/src/fsharp/TypedTree.fs +++ b/src/fsharp/TypedTree.fs @@ -4116,7 +4116,7 @@ type AttribNamedArg = override x.ToString() = sprintf "AttribNamedArg(...)" /// Constants in expressions -[] +[] type Const = | Bool of bool | SByte of sbyte @@ -4137,6 +4137,30 @@ type Const = | Unit | Zero // null/zero-bit-pattern + [] + member x.DebugText = x.ToString() + + override c.ToString() = + match c with + | Bool b -> (if b then "true" else "false") + | SByte x -> string x + "y" + | Byte x -> string x + "uy" + | Int16 x -> string x + "s" + | UInt16 x -> string x + "us" + | Int32 x -> string x + | UInt32 x -> string x + "u" + | Int64 x -> string x + "L" + | UInt64 x -> string x + "UL" + | IntPtr x -> string x + "n" + | UIntPtr x -> string x + "un" + | Single x -> string x + "f" + | Double x -> string x + | Char x -> "'" + string x + "'" + | String x -> "\"" + x + "\"" + | Decimal x -> string x + "M" + | Unit -> "()" + | Zero -> "Const.Zero" + /// Decision trees. Pattern matching has been compiled down to /// a decision tree by this point. The right-hand-sides (actions) of /// a decision tree by this point. The right-hand-sides (actions) of @@ -4235,7 +4259,7 @@ type DecisionTreeTest = /// A target of a decision tree. Can be thought of as a little function, though is compiled as a local block. [] type DecisionTreeTarget = - | TTarget of Vals * Expr * DebugPointForTarget + | TTarget of Val list * Expr * DebugPointForTarget [] member x.DebugText = x.ToString() @@ -4359,7 +4383,7 @@ type Exprs = Expr list type Vals = Val list /// Represents an expression in the typed abstract syntax -[] +[] type Expr = /// A constant expression. | Const of @@ -4496,13 +4520,32 @@ type Expr = /// appropriate type instantiation. These are immediately eliminated on subsequent rewrites. | Link of Expr ref - // Prefer to use the default formatting of this union type - //[] - //member x.DebugText = x.ToString() - // - //override __.ToString() = "Expr(...)" - -[] + [] + member expr.DebugText = expr.ToDebugString(3) + + override expr.ToString() = expr.ToDebugString(3) + + member expr.ToDebugString(depth: int) = + if depth = 0 then ".." else + let depth = depth - 1 + match expr with + | Const (c, _, _) -> c.ToString() + | Val (v, _, _) -> v.LogicalName + | Sequential (e1, e2, _, _, _) -> "Sequential(" + e1.ToDebugString(depth) + ", " + e2.ToDebugString(depth) + ")" + | Lambda (_, _, _, vs, body, _, _) -> sprintf "Lambda(%+A, " vs + body.ToDebugString(depth) + ")" + | TyLambda (_, tps, body, _, _) -> sprintf "TyLambda(%+A, " tps + body.ToDebugString(depth) + ")" + | App (f, _, _, args, _) -> "App(" + f.ToDebugString(depth) + ", [" + String.concat ", " (args |> List.map (fun e -> e.ToDebugString(depth))) + "])" + | LetRec _ -> "LetRec(..)" + | Let (bind, body, _, _) -> "Let(" + bind.Var.DisplayName + ", " + bind.Expr.ToDebugString(depth) + ", " + body.ToDebugString(depth) + ")" + | Obj (_, _objTy, _, _, _, _, _) -> "Obj(..)" + | Match (_, _, _dt, _tgs, _, _) -> "Match(..)" + | StaticOptimization (_, _, _, _) -> "StaticOptimization(..)" + | Op (op, _, args, _) -> "Op(" + op.ToString() + ", " + String.concat ", " (args |> List.map (fun e -> e.ToDebugString(depth))) + ")" + | Quote _ -> "Quote(..)" + | TyChoose _ -> "TyChoose(..)" + | Link e -> "Link(" + e.Value.ToDebugString(depth) + ")" + +[] type TOp = /// An operation representing the creation of a union value of the particular union case @@ -4619,11 +4662,45 @@ type TOp = /// retTy -- the types of pushed values, if any | ILCall of bool * bool * bool * bool * ValUseFlag * bool * bool * ILMethodRef * TypeInst * TypeInst * TTypes - // Prefer to use the default formatting of this union type - //[] - //member x.DebugText = x.ToString() - // - //override __.ToString() = "TOp(...)" + [] + member x.DebugText = x.ToString() + + override op.ToString() = + match op with + | UnionCase ucref -> "UnionCase(" + ucref.CaseName + ")" + | ExnConstr ecref -> "ExnConstr(" + ecref.LogicalName + ")" + | Tuple _tupinfo -> "Tuple" + | AnonRecd _anonInfo -> "AnonRecd(..)" + | AnonRecdGet _ -> "AnonRecdGet(..)" + | Array -> "NewArray" + | Bytes _ -> "Bytes(..)" + | UInt16s _ -> "UInt16s(..)" + | While _ -> "While" + | For _ -> "For" + | TryCatch _ -> "TryCatch" + | TryFinally _ -> "TryFinally" + | Recd (_, tcref) -> "Recd(" + tcref.LogicalName + ")" + | ValFieldSet rfref -> "ValFieldSet(" + rfref.FieldName + ")" + | ValFieldGet rfref -> "ValFieldGet(" + rfref.FieldName + ")" + | ValFieldGetAddr (rfref, _) -> "ValFieldGetAddr(" + rfref.FieldName + ",..)" + | UnionCaseTagGet tcref -> "UnionCaseTagGet(" + tcref.LogicalName + ")" + | UnionCaseProof ucref -> "UnionCaseProof(" + ucref.CaseName + ")" + | UnionCaseFieldGet (ucref, _) -> "UnionCaseFieldGet(" + ucref.CaseName + ",..)" + | UnionCaseFieldGetAddr (ucref, _, _) -> "UnionCaseFieldGetAddr(" + ucref.CaseName + ",..)" + | UnionCaseFieldSet (ucref, _) -> "UnionCaseFieldSet(" + ucref.CaseName + ",..)" + | ExnFieldGet (tcref, _) -> "ExnFieldGet(" + tcref.LogicalName + ",..)" + | ExnFieldSet (tcref, _) -> "ExnFieldSet(" + tcref.LogicalName + ",..)" + | TupleFieldGet _ -> "TupleFieldGet(..)" + | ILAsm _ -> "ILAsm(..)" + | RefAddrGet _ -> "RefAddrGet(..)" + | Coerce -> "Coerce" + | Reraise -> "Reraise" + | Return -> "Return" + | Goto n -> "Goto(" + string n + ")" + | Label n -> "Label(" + string n + ")" + | TraitCall info -> "TraitCall(" + info.MemberName + ")" + | LValueOp (op, vref) -> sprintf "%+A(%s)" op vref.LogicalName + | ILCall (_,_,_,_,_,_,_,m,_,_,_) -> "ILCall(" + m.ToString() + ",..)" /// Represents the kind of record construction operation. type RecordConstructionInfo = diff --git a/src/fsharp/TypedTreeOps.fs b/src/fsharp/TypedTreeOps.fs index 168cf5ee189..86715cfed75 100644 --- a/src/fsharp/TypedTreeOps.fs +++ b/src/fsharp/TypedTreeOps.fs @@ -3717,7 +3717,7 @@ module DebugPrint = reprL and bindingL g (TBind(v, repr, _)) = - valAtBindL g v --- (wordL(tagText "=") ^^ exprL g repr) + (valAtBindL g v ^^ wordL(tagText "=")) @@-- exprL g repr and exprL g expr = exprWrapL g false expr @@ -3731,15 +3731,13 @@ module DebugPrint = (aboveListL eqnsL @@ bodyL) and letL g bind bodyL = - let eqnL = wordL(tagText "let") ^^ bindingL g bind ^^ wordL(tagText "in") + let eqnL = wordL(tagText "let") ^^ bindingL g bind (eqnL @@ bodyL) and exprWrapL g isAtomic expr = let atomL args = atomL g args let exprL expr = exprL g expr - let iimplL iimpls = iimplL g iimpls let valAtBindL v = valAtBindL g v - let overrideL tmeth = overrideL g tmeth let targetL targets = targetL g targets let wrap = bracketIfL isAtomic // wrap iff require atomic expr let lay = @@ -3758,8 +3756,8 @@ module DebugPrint = | Expr.Sequential (expr1, expr2, flag, _, _) -> let flag = match flag with - | NormalSeq -> "; (*Seq*)" - | ThenDoSeq -> "; (*ThenDo*)" + | NormalSeq -> ";" + | ThenDoSeq -> "; ThenDo" ((exprL expr1 ^^ rightL (tagText flag)) @@ exprL expr2) |> wrap | Expr.Lambda (_, _, baseValOpt, argvs, body, _, _) -> let formalsL = spaceListL (List.map valAtBindL argvs) in @@ -3834,22 +3832,22 @@ module DebugPrint = let meth = ilMethRef.Name wordL(tagText "ILCall") ^^ aboveListL - [ wordL(tagText "meth ") --- wordL (tagText ilMethRef.DeclaringTypeRef.FullName) ^^ sepL(tagText ".") ^^ wordL (tagText meth) - wordL(tagText "tinst ") --- listL typeL tinst - wordL(tagText "minst ") --- listL typeL minst - wordL(tagText "tyargs") --- listL typeL tyargs - wordL(tagText "args ") --- listL exprL args ] + [ yield wordL (tagText ilMethRef.DeclaringTypeRef.FullName) ^^ sepL(tagText ".") ^^ wordL (tagText meth) + if not tinst.IsEmpty then yield wordL(tagText "tinst ") --- listL typeL tinst + if not minst.IsEmpty then yield wordL (tagText "minst ") --- listL typeL minst + if not tyargs.IsEmpty then yield wordL (tagText "tyargs") --- listL typeL tyargs + if not args.IsEmpty then yield listL exprL args ] |> wrap | Expr.Op (TOp.Array, [_], xs, _) -> leftL(tagText "[|") ^^ commaListL (List.map exprL xs) ^^ rightL(tagText "|]") - | Expr.Op (TOp.While _, [], [x1;x2], _) -> - wordL(tagText "while") ^^ exprL x1 ^^ wordL(tagText "do") ^^ exprL x2 ^^ rightL(tagText "}") - | Expr.Op (TOp.For _, [], [x1;x2;x3], _) -> + | Expr.Op (TOp.While _, [], [Expr.Lambda (_, _, _, [_], x1, _, _);Expr.Lambda (_, _, _, [_], x2, _, _)], _) -> + (wordL(tagText "while") ^^ exprL x1 ^^ wordL(tagText "do")) @@-- exprL x2 + | Expr.Op (TOp.For _, [], [Expr.Lambda (_, _, _, [_], x1, _, _);Expr.Lambda (_, _, _, [_], x2, _, _);Expr.Lambda (_, _, _, [_], x3, _, _)], _) -> wordL(tagText "for") ^^ aboveListL [(exprL x1 ^^ wordL(tagText "to") ^^ exprL x2 ^^ wordL(tagText "do")); exprL x3 ] ^^ rightL(tagText "done") - | Expr.Op (TOp.TryCatch _, [_], [x1;x2], _) -> - wordL(tagText "try") ^^ exprL x1 ^^ wordL(tagText "with") ^^ exprL x2 ^^ rightL(tagText "}") - | Expr.Op (TOp.TryFinally _, [_], [x1;x2], _) -> - wordL(tagText "try") ^^ exprL x1 ^^ wordL(tagText "finally") ^^ exprL x2 ^^ rightL(tagText "}") + | Expr.Op (TOp.TryCatch _, [_], [Expr.Lambda (_, _, _, [_], x1, _, _);Expr.Lambda (_, _, _, [_], xf, _, _);Expr.Lambda (_, _, _, [_], xh, _, _)], _) -> + (wordL (tagText "try") @@-- exprL x1) @@ (wordL(tagText "with-filter") @@-- exprL xf) @@ (wordL(tagText "with") @@-- exprL xh) + | Expr.Op (TOp.TryFinally _, [_], [Expr.Lambda (_, _, _, [_], x1, _, _);Expr.Lambda (_, _, _, [_], x2, _, _)], _) -> + (wordL (tagText "try") @@-- exprL x1) @@ (wordL(tagText "finally") @@-- exprL x2) | Expr.Op (TOp.Bytes _, _, _, _) -> wordL(tagText "bytes++") | Expr.Op (TOp.UInt16s _, _, _, _) -> wordL(tagText "uint16++") @@ -3859,15 +3857,21 @@ module DebugPrint = | Expr.Op (TOp.ExnFieldSet _, _tyargs, _args, _) -> wordL(tagText "TOp.ExnFieldSet...") | Expr.Op (TOp.TryFinally _, _tyargs, _args, _) -> wordL(tagText "TOp.TryFinally...") | Expr.Op (TOp.TryCatch _, _tyargs, _args, _) -> wordL(tagText "TOp.TryCatch...") + | Expr.Op (TOp.Goto l, _tys, args, _) -> wordL(tagText ("Expr.Goto " + string l)) ^^ bracketL (commaListL (List.map atomL args)) + | Expr.Op (TOp.Label l, _tys, args, _) -> wordL(tagText ("Expr.Label " + string l)) ^^ bracketL (commaListL (List.map atomL args)) | Expr.Op (_, _tys, args, _) -> wordL(tagText "Expr.Op ...") ^^ bracketL (commaListL (List.map atomL args)) | Expr.Quote (a, _, _, _, _) -> leftL(tagText "<@") ^^ atomL a ^^ rightL(tagText "@>") | Expr.Obj (_lambdaId, ty, basev, ccall, overrides, iimpls, _) -> - wordL(tagText "OBJ:") ^^ - aboveListL [typeL ty - exprL ccall - optionL valAtBindL basev - aboveListL (List.map overrideL overrides) - aboveListL (List.map iimplL iimpls)] + (leftL (tagText "{") + @@-- + ((wordL(tagText "new ") ++ typeL ty) + @@-- + aboveListL [exprL ccall + optionL valAtBindL basev + aboveListL (List.map (tmethodL g) overrides) + aboveListL (List.map (iimplL g) iimpls)])) + @@ + rightL (tagText "}") | Expr.StaticOptimization (_tcs, csx, x, _) -> (wordL(tagText "opt") @@- (exprL x)) @@-- @@ -3879,14 +3883,12 @@ module DebugPrint = else lay and implFilesL g implFiles = - let implFileL implFiles = implFileL g implFiles - aboveListL (List.map implFileL implFiles) + aboveListL (List.map (implFileL g) implFiles) and appL g flayout tys args = - let atomL args = atomL g args let z = flayout - let z = z ^^ instL typeL tys - let z = z --- sepL(tagText "`") --- (spaceListL (List.map atomL args)) + let z = if tys.Length > 0 then z ^^ instL typeL tys else z + let z = if args.Length > 0 then z --- spaceListL (List.map (atomL g) args) else z z and implFileL g (TImplFile (_, _, mexpr, _, _, _)) = @@ -3897,14 +3899,11 @@ module DebugPrint = | ModuleOrNamespaceExprWithSig(mtyp, defs, _) -> mdefL g defs @@- (wordL(tagText ":") @@- entityTypeL g mtyp) and mdefsL g defs = - let mdefL x = mdefL g x - wordL(tagText "Module Defs") @@-- aboveListL(List.map mdefL defs) + wordL(tagText "Module Defs") @@-- aboveListL(List.map (mdefL g) defs) and mdefL g x = - let tyconL tycon = tyconL g tycon - let mbindL x = mbindL g x match x with - | TMDefRec(_, tycons, mbinds, _) -> aboveListL ((tycons |> List.map tyconL) @ List.map mbindL mbinds) + | TMDefRec(_, tycons, mbinds, _) -> aboveListL ((tycons |> List.map (tyconL g)) @ (mbinds |> List.map (mbindL g))) | TMDefLet(bind, _) -> letL g bind emptyL | TMDefDo(e, _) -> exprL g e | TMDefs defs -> mdefsL g defs @@ -3917,9 +3916,8 @@ module DebugPrint = (wordL (tagText (if mspec.IsNamespace then "namespace" else "module")) ^^ (wordL (tagText mspec.DemangledModuleOrNamespaceName) |> stampL mspec.Stamp)) @@-- mdefL g rhs and entityTypeL g (mtyp: ModuleOrNamespaceType) = - let tyconL tycon = tyconL g tycon aboveListL [jlistL typeOfValL mtyp.AllValsAndMembers - jlistL tyconL mtyp.AllEntities] + jlistL (tyconL g) mtyp.AllEntities] and entityL g (ms: ModuleOrNamespace) = let header = wordL(tagText "module") ^^ (wordL (tagText ms.DemangledModuleOrNamespaceName) |> stampL ms.Stamp) ^^ wordL(tagText ":") @@ -3930,17 +3928,15 @@ module DebugPrint = and ccuL g (ccu: CcuThunk) = entityL g ccu.Contents and decisionTreeL g x = - let exprL expr = exprL g expr - let dcaseL dcases = dcaseL g dcases match x with | TDBind (bind, body) -> - let bind = wordL(tagText "let") ^^ bindingL g bind ^^ wordL(tagText "in") + let bind = wordL(tagText "let") ^^ bindingL g bind (bind @@ decisionTreeL g body) | TDSuccess (args, n) -> - wordL(tagText "Success") ^^ leftL(tagText "T") ^^ intL n ^^ tupleL (args |> List.map exprL) + wordL(tagText "Success") ^^ leftL(tagText "T") ^^ intL n ^^ tupleL (args |> List.map (exprL g)) | TDSwitch (test, dcases, dflt, _) -> - (wordL(tagText "Switch") --- exprL test) @@-- - (aboveListL (List.map dcaseL dcases) @@ + (wordL(tagText "Switch") --- exprL g test) @@-- + (aboveListL (List.map (dcaseL g) dcases) @@ match dflt with | None -> emptyL | Some dtree -> wordL(tagText "dflt:") --- decisionTreeL g dtree) @@ -3957,22 +3953,19 @@ module DebugPrint = | (DecisionTreeTest.ActivePatternCase (exp, _, _, _, _)) -> wordL(tagText "query") ^^ exprL g exp | (DecisionTreeTest.Error _) -> wordL (tagText "error recovery") - and targetL g i (TTarget (argvs, body, _)) = leftL(tagText "T") ^^ intL i ^^ tupleL (flatValsL argvs) ^^ rightL(tagText ":") --- exprL g body + and targetL g i (TTarget (argvs, body, _)) = + leftL(tagText "T") ^^ intL i ^^ tupleL (flatValsL argvs) ^^ rightL(tagText ":") --- exprL g body and flatValsL vs = vs |> List.map valL and tmethodL g (TObjExprMethod(TSlotSig(nm, _, _, _, _, _), _, tps, vs, e, _)) = - let valAtBindL v = valAtBindL g v - (wordL(tagText "TObjExprMethod") --- (wordL (tagText nm)) ^^ wordL(tagText "=")) -- - (wordL(tagText "METH-LAM") --- angleBracketListL (List.map typarL tps) ^^ rightL(tagText ".")) --- - (wordL(tagText "meth-lam") --- tupleL (List.map (List.map valAtBindL >> tupleL) vs) ^^ rightL(tagText ".")) --- + ((wordL(tagText "TObjExprMethod") --- (wordL (tagText nm)) ^^ wordL(tagText "=")) -- + (angleBracketListL (List.map typarL tps) ^^ rightL(tagText ".")) --- + (tupleL (List.map (List.map (valAtBindL g) >> tupleL) vs) ^^ rightL(tagText "."))) + @@-- (atomL g e) - and overrideL g tmeth = wordL(tagText "with") ^^ tmethodL g tmeth - - and iimplL g (ty, tmeths) = - let tmethodL p = tmethodL g p - wordL(tagText "impl") ^^ aboveListL (typeL ty :: List.map tmethodL tmeths) + and iimplL g (ty, tmeths) = wordL(tagText "impl") ^^ aboveListL (typeL ty :: List.map (tmethodL g) tmeths) let showType x = Layout.showL (typeL x) @@ -7098,7 +7091,9 @@ let destThrow = function let isThrow x = Option.isSome (destThrow x) // reraise - parsed as library call - internally represented as op form. -let mkReraiseLibCall (g: TcGlobals) ty m = let ve, vt = typedExprForIntrinsic g m g.reraise_info in Expr.App (ve, vt, [ty], [mkUnit g m], m) +let mkReraiseLibCall (g: TcGlobals) ty m = + let ve, vt = typedExprForIntrinsic g m g.reraise_info + Expr.App (ve, vt, [ty], [mkUnit g m], m) let mkReraise m returnTy = Expr.Op (TOp.Reraise, [returnTy], [], m) (* could suppress unitArg *) @@ -7749,9 +7744,8 @@ let LinearizeTopMatchAux g parent (spBind, m, tree, targets, m2, ty) = | tys -> Expr.Op (TOp.TupleFieldGet (tupInfoRef, i), tys, [x], m) let isThrowingTarget = function TTarget(_, x, _) -> isThrow x if 1 + List.count isThrowingTarget targetsL = targetsL.Length then - (* Have failing targets and ONE successful one, so linearize *) - let (TTarget (vs, rhs, spTarget)) = Option.get (List.tryFind (isThrowingTarget >> not) targetsL) - (* note - old code here used copy value to generate locals - this was not right *) + // Have failing targets and ONE successful one, so linearize + let (TTarget (vs, rhs, spTarget)) = List.find (isThrowingTarget >> not) targetsL let fvs = vs |> List.map (fun v -> fst(mkLocal v.Range v.LogicalName v.Type)) (* fresh *) let vtys = vs |> List.map (fun v -> v.Type) let tmpTy = mkRefTupledVarsTy g vs @@ -8320,7 +8314,7 @@ and preRewriteExpr env expr = and postRewriteExpr env expr = match env.PostTransform expr with | None -> expr - | Some expr -> expr + | Some expr2 -> expr2 and rewriteExprStructure env expr = match expr with @@ -8359,7 +8353,7 @@ and rewriteExprStructure env expr = mkTypeLambda m argtyvs (body, rty) | Expr.Match (spBind, exprm, dtree, targets, m, ty) -> - let dtree' = rewriteDecisionTree env dtree + let dtree' = RewriteDecisionTree env dtree let targets' = rewriteTargets env targets mkAndSimplifyMatch spBind exprm m ty dtree' targets' @@ -8408,7 +8402,7 @@ and rewriteLinearExpr env expr contf = else rebuildLinearOpExpr (op, tyargs, argsFront', argLast', m))) | LinearMatchExpr (spBind, exprm, dtree, tg1, expr2, sp2, m2, ty) -> - let dtree = rewriteDecisionTree env dtree + let dtree = RewriteDecisionTree env dtree let tg1' = rewriteTarget env tg1 // tailcall rewriteLinearExpr env expr2 (contf << (fun expr2' -> @@ -8421,7 +8415,7 @@ and rewriteExprs env exprs = List.mapq (RewriteExpr env) exprs and rewriteFlatExprs env exprs = List.mapq (RewriteExpr env) exprs -and rewriteDecisionTree env x = +and RewriteDecisionTree env x = match x with | TDSuccess (es, n) -> let es' = rewriteFlatExprs env es @@ -8430,24 +8424,26 @@ and rewriteDecisionTree env x = | TDSwitch (e, cases, dflt, m) -> let e' = RewriteExpr env e - let cases' = List.map (fun (TCase(discrim, e)) -> TCase(discrim, rewriteDecisionTree env e)) cases - let dflt' = Option.map (rewriteDecisionTree env) dflt + let cases' = List.map (fun (TCase(discrim, e)) -> TCase(discrim, RewriteDecisionTree env e)) cases + let dflt' = Option.map (RewriteDecisionTree env) dflt TDSwitch (e', cases', dflt', m) | TDBind (bind, body) -> let bind' = rewriteBind env bind - let body = rewriteDecisionTree env body + let body = RewriteDecisionTree env body TDBind (bind', body) -and rewriteTarget env (TTarget(vs, e, spTarget)) = TTarget(vs, RewriteExpr env e, spTarget) +and rewriteTarget env (TTarget(vs, e, spTarget)) = + TTarget(vs, RewriteExpr env e, spTarget) -and rewriteTargets env targets = List.map (rewriteTarget env) (Array.toList targets) +and rewriteTargets env targets = + List.map (rewriteTarget env) (Array.toList targets) and rewriteObjExprOverride env (TObjExprMethod(slotsig, attribs, tps, vs, e, m)) = - TObjExprMethod(slotsig, attribs, tps, vs, RewriteExpr env e, m) + TObjExprMethod(slotsig, attribs, tps, vs, RewriteExpr env e, m) and rewriteObjExprInterfaceImpl env (ty, overrides) = - (ty, List.map (rewriteObjExprOverride env) overrides) + (ty, List.map (rewriteObjExprOverride env) overrides) and rewriteModuleOrNamespaceExpr env x = match x with @@ -8660,8 +8656,10 @@ let IsSimpleSyntacticConstantExpr g inputExpr = | TDSuccess (es, _n) -> es |> List.forall (checkExpr vrefs) | TDSwitch (e, cases, dflt, _m) -> checkExpr vrefs e && cases |> List.forall (checkDecisionTreeCase vrefs) && dflt |> Option.forall (checkDecisionTree vrefs) | TDBind (bind, body) -> checkExpr vrefs bind.Expr && checkDecisionTree (vrefs.Add bind.Var.Stamp) body + and checkDecisionTreeCase vrefs (TCase(discrim, dtree)) = (match discrim with DecisionTreeTest.Const _c -> true | _ -> false) && checkDecisionTree vrefs dtree + and checkDecisionTreeTarget vrefs (TTarget(vs, e, _)) = let vrefs = ((vrefs, vs) ||> List.fold (fun s v -> s.Add v.Stamp)) checkExpr vrefs e @@ -8845,6 +8843,7 @@ let mkGetTupleItemN g m n (ty: ILType) isStruct te retty = mkAsmExpr ([mkNormalLdfld (mkILFieldSpecForTupleItem ty n) ], [], [te], [retty], m) else mkAsmExpr ([IL.mkNormalCall(mkILMethodSpecForTupleItem g ty n)], [], [te], [retty], m) + /// Match an Int32 constant expression let (|Int32Expr|_|) expr = match expr with @@ -9023,6 +9022,11 @@ let mkUnitDelayLambda (g: TcGlobals) m e = let uv, _ = mkCompGenLocal m "unitVar" g.unit_ty mkLambda m uv (e, tyOfExpr g e) +let (|ValApp|_|) g vref expr = + match expr with + // use 'seq { ... }' as an indicator + | Expr.App (Expr.Val (vref2, _, _), _f0ty, tyargs, args, m) when valRefEq g vref vref2 -> Some (tyargs, args, m) + | _ -> None let isStaticClass (g:TcGlobals) (x: EntityRef) = not x.IsModuleOrNamespace && diff --git a/src/fsharp/TypedTreeOps.fsi b/src/fsharp/TypedTreeOps.fsi index 32ae0ff6dc4..255b11600dd 100755 --- a/src/fsharp/TypedTreeOps.fsi +++ b/src/fsharp/TypedTreeOps.fsi @@ -2323,6 +2323,9 @@ val isThreadOrContextStatic: TcGlobals -> Attrib list -> bool val mkUnitDelayLambda: TcGlobals -> range -> Expr -> Expr +/// Match expressions that are an application of a particular F# function value +val (|ValApp|_|) : TcGlobals -> ValRef -> Expr -> (TypeInst * Exprs * range) option + val isStaticClass: g: TcGlobals -> tcref: TyconRef -> bool val CombineCcuContentFragments: range -> ModuleOrNamespaceType list -> ModuleOrNamespaceType \ No newline at end of file diff --git a/src/fsharp/range.fs b/src/fsharp/range.fs index ccdea8979bb..05123e465be 100755 --- a/src/fsharp/range.fs +++ b/src/fsharp/range.fs @@ -206,11 +206,7 @@ let startupFileName = "startup" let commandLineArgsFileName = "commandLineArgs" [] -#if DEBUG -[ {DebugCode}")>] -#else -[] -#endif +[ {DebugCode}")>] type range(code1:int64, code2: int64) = static member Zero = range(0L, 0L) new (fIdx, bl, bc, el, ec) = @@ -246,13 +242,14 @@ type range(code1:int64, code2: int64) = member r.FileName = fileOfFileIndex r.FileIndex + member r.ShortFileName = Path.GetFileName(fileOfFileIndex r.FileIndex) + member r.MakeSynthetic() = range(code1, code2 ||| isSyntheticMask) member r.Code1 = code1 member r.Code2 = code2 -#if DEBUG member r.DebugCode = let name = r.FileName if name = unknownFileName || name = startupFileName || name = commandLineArgsFileName then name else @@ -270,7 +267,6 @@ type range(code1:int64, code2: int64) = |> fun s -> s.Substring(startCol + 1, s.LastIndexOf("\n", StringComparison.Ordinal) + 1 - startCol + endCol) with e -> e.ToString() -#endif member r.ToShortString() = sprintf "(%d,%d--%d,%d)" r.StartLine r.StartColumn r.EndLine r.EndColumn