diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index 0926327aa8f..57fab47e78d 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -3001,7 +3001,7 @@ namespace Microsoft.FSharp.Collections open Microsoft.FSharp.Core.BasicInlinedOperations [] - [>)>] + [>)>] [] [] [] @@ -3040,10 +3040,10 @@ namespace Microsoft.FSharp.Collections | [] -> () | h::t -> if i < n then - SetArray items i h; + SetArray items i h copy items t (i+1) - copy items l 0; + copy items l 0 items type ResizeArray<'T> = System.Collections.Generic.List<'T> diff --git a/src/fsharp/InnerLambdasToTopLevelFuncs.fs b/src/fsharp/InnerLambdasToTopLevelFuncs.fs index 2703e29c322..e2547a9325d 100644 --- a/src/fsharp/InnerLambdasToTopLevelFuncs.fs +++ b/src/fsharp/InnerLambdasToTopLevelFuncs.fs @@ -958,12 +958,16 @@ module Pass4_RewriteAssembly = #endif /// Wrap preDecs (in order) over an expr - use letrec/let as approp - let MakePreDec m (isRec,binds) expr = + let MakePreDec m (isRec,binds: Bindings) expr = if isRec=IsRec then - mkLetRecBinds m binds expr + // By definition top level bindings don't refer to non-top level bindings, so we can build them in two parts + let topLevelBinds, nonTopLevelBinds = binds |> List.partition (fun bind -> bind.Var.IsCompiledAsTopLevel) + mkLetRecBinds m topLevelBinds (mkLetRecBinds m nonTopLevelBinds expr) else mkLetsFromBindings m binds expr + /// Must MakePreDecs around every construct that could do EnterInner (which filters TLR decs). + /// i.e. let,letrec (bind may...), ilobj, lambda, tlambda. let MakePreDecs m preDecs expr = List.foldBack (MakePreDec m) preDecs expr let RecursivePreDecs pdsA pdsB = @@ -1099,11 +1103,6 @@ module Pass4_RewriteAssembly = // pass4: pass (over expr) //------------------------------------------------------------------------- - /// Must WrapPreDecs around every construct that could do EnterInner (which filters TLR decs). - /// i.e. let,letrec (bind may...), ilobj, lambda, tlambda. - let WrapPreDecs m pds x = - MakePreDecs m pds x - /// At bindings, fixup any TLR bindings. /// At applications, fixup calls if they are arity-met instances of TLR. /// At free vals, fixup 0-call if it is an arity-met constant. @@ -1146,7 +1145,7 @@ module Pass4_RewriteAssembly = (tType,objExprs'),z') z iimpls let expr = Expr.Obj(newUnique(),ty,basev,basecall,overrides,iimpls,m) let pds,z = ExtractPreDecs z - WrapPreDecs m pds expr,z (* if TopLevel, lift preDecs over the ilobj expr *) + MakePreDecs m pds expr,z (* if TopLevel, lift preDecs over the ilobj expr *) // lambda, tlambda - explicit lambda terms | Expr.Lambda(_,ctorThisValOpt,baseValOpt,argvs,body,m,rty) -> @@ -1154,14 +1153,14 @@ module Pass4_RewriteAssembly = let body,z = TransExpr penv z body let z = ExitInner z let pds,z = ExtractPreDecs z - WrapPreDecs m pds (rebuildLambda m ctorThisValOpt baseValOpt argvs (body,rty)),z + MakePreDecs m pds (rebuildLambda m ctorThisValOpt baseValOpt argvs (body,rty)),z | Expr.TyLambda(_,argtyvs,body,m,rty) -> let z = EnterInner z let body,z = TransExpr penv z body let z = ExitInner z let pds,z = ExtractPreDecs z - WrapPreDecs m pds (mkTypeLambda m argtyvs (body,rty)),z + MakePreDecs m pds (mkTypeLambda m argtyvs (body,rty)),z /// Lifting TLR out over constructs (disabled) /// Lift minimally to ensure the defn is not lifted up and over defns on which it depends (disabled) @@ -1171,7 +1170,7 @@ module Pass4_RewriteAssembly = let targets,z = List.mapFold (TransDecisionTreeTarget penv) z targets // TransDecisionTreeTarget wraps EnterInner/exitInnter, so need to collect any top decs let pds,z = ExtractPreDecs z - WrapPreDecs m pds (mkAndSimplifyMatch spBind exprm m ty dtree targets),z + MakePreDecs m pds (mkAndSimplifyMatch spBind exprm m ty dtree targets),z // all others - below - rewrite structurally - so boiler plate code after this point... | Expr.Const _ -> expr,z (* constant wrt Val *) @@ -1216,7 +1215,7 @@ module Pass4_RewriteAssembly = // tailcall TransLinearExpr penv z e (contf << (fun (e,z) -> let e = mkLetsFromBindings m rebinds e - WrapPreDecs m pds (Expr.LetRec (binds,e,m,NewFreeVarsCache())),z)) + MakePreDecs m pds (Expr.LetRec (binds,e,m,NewFreeVarsCache())),z)) // let - can consider the mu-let bindings as mu-letrec bindings - so like as above | Expr.Let (bind,e,m,_) -> @@ -1232,7 +1231,7 @@ module Pass4_RewriteAssembly = // tailcall TransLinearExpr penv z e (contf << (fun (e,z) -> let e = mkLetsFromBindings m rebinds e - WrapPreDecs m pds (mkLetsFromBindings m binds e),z)) + MakePreDecs m pds (mkLetsFromBindings m binds e),z)) | LinearMatchExpr (spBind,exprm,dtree,tg1,e2,sp2,m2,ty) -> let dtree,z = TransDecisionTree penv z dtree diff --git a/src/fsharp/LowerCallsAndSeqs.fs b/src/fsharp/LowerCallsAndSeqs.fs index d347ef3c9e7..7e6ba07feda 100644 --- a/src/fsharp/LowerCallsAndSeqs.fs +++ b/src/fsharp/LowerCallsAndSeqs.fs @@ -179,6 +179,39 @@ let LowerSeqExpr g amap overallExpr = | Expr.App(Expr.Val (vref,_,_),_f0ty,[elemTy],[e],_m) when valRefEq g vref g.seq_vref -> Some (e,elemTy) | _ -> None + let RepresentBindingAsStateMachineLocal (bind: Binding) res2 m = + // printfn "found letrec state variable %s" bind.Var.DisplayName + let (TBind(v,e,sp)) = bind + let sp,spm = + match sp with + | SequencePointAtBinding m -> SequencePointsAtSeq,m + | _ -> SuppressSequencePointOnExprOfSequential,e.Range + let vref = mkLocalValRef v + { res2 with + phase2 = (fun ctxt -> + let generate2,dispose2,checkDispose2 = res2.phase2 ctxt + let generate = + mkCompGenSequential m + (mkSequential sp m + (mkValSet spm vref e) + generate2) + // zero out the current value to free up its memory + (mkValSet m vref (mkDefault (m,vref.Type))) + let dispose = dispose2 + let checkDispose = checkDispose2 + generate,dispose,checkDispose) + stateVars = vref::res2.stateVars } + + let RepresentBindingsAsLifted mkBinds res2 = + // printfn "found top level let " + { res2 with + phase2 = (fun ctxt -> + let generate2,dispose2,checkDispose2 = res2.phase2 ctxt + let generate = mkBinds generate2 + let dispose = dispose2 + let checkDispose = checkDispose2 + generate,dispose, checkDispose) } + let rec Lower isWholeExpr isTailCall // is this sequence in tailcall position? @@ -220,6 +253,7 @@ let LowerSeqExpr g amap overallExpr = | SeqDelay(e,_elemTy) -> // printfn "found Seq.delay" Lower isWholeExpr isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel e // note, using 'isWholeExpr' here prevents 'seq { yield! e }' and 'seq { 0 .. 1000 }' from being compiled + | SeqAppend(e1,e2,m) -> // printfn "found Seq.append" match Lower false false noDisposeContinuationLabel currentDisposeContinuationLabel e1, @@ -239,6 +273,7 @@ let LowerSeqExpr g amap overallExpr = significantClose = res1.significantClose || res2.significantClose } | _ -> None + | SeqWhile(e1,e2,m) -> // printfn "found Seq.while" match Lower false false noDisposeContinuationLabel currentDisposeContinuationLabel e2 with @@ -254,9 +289,11 @@ let LowerSeqExpr g amap overallExpr = significantClose = res2.significantClose } | _ -> None + | SeqUsing(resource,v,body,elemTy,m) -> // printfn "found Seq.using" Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel (mkLet (SequencePointAtBinding body.Range) m v resource (mkCallSeqFinally g m elemTy body (mkUnitDelayLambda g m (mkCallDispose g m v.Type (exprForVal m v))))) + | SeqFor(inp,v,body,genElemTy,m) -> // printfn "found Seq.for" let inpElemTy = v.Type @@ -272,6 +309,7 @@ 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]) body)))) + | SeqTryFinally(e1,compensation,m) -> // printfn "found Seq.try/finally" let innerDisposeContinuationLabel = IL.generateCodeLabel() @@ -318,6 +356,7 @@ let LowerSeqExpr g amap overallExpr = significantClose = true } | _ -> None + | SeqEmpty m -> // printfn "found Seq.empty" Some { phase2 = (fun _ -> @@ -328,6 +367,7 @@ let LowerSeqExpr g amap overallExpr = labels = [] stateVars = [] significantClose = false } + | Expr.Sequential(x1,x2,NormalSeq,ty,m) -> match Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel x2 with | Some res2-> @@ -343,41 +383,43 @@ let LowerSeqExpr g amap overallExpr = | Expr.Let(bind,e2,m,_) // Restriction: compilation of sequence expressions containing non-toplevel constrained generic functions is not supported - when not bind.Var.IsCompiledAsTopLevel && - not (IsGenericValWithGenericContraints g bind.Var) -> + when bind.Var.IsCompiledAsTopLevel || not (IsGenericValWithGenericContraints g bind.Var) -> match Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel e2 with | Some res2 -> if bind.Var.IsCompiledAsTopLevel then - // printfn "found top level let " - Some { res2 with - phase2 = (fun ctxt -> - let generate2,dispose2,checkDispose2 = res2.phase2 ctxt - let generate = mkLetBind m bind generate2 - let dispose = dispose2 - let checkDispose = checkDispose2 - generate,dispose, checkDispose) } + Some (RepresentBindingsAsLifted (mkLetBind m bind) res2) else // printfn "found state variable %s" bind.Var.DisplayName - let (TBind(v,e,sp)) = bind - let sp,spm = - match sp with - | SequencePointAtBinding m -> SequencePointsAtSeq,m - | _ -> SuppressSequencePointOnExprOfSequential,e.Range - let vref = mkLocalValRef v - Some { res2 with - phase2 = (fun ctxt -> - let generate2,dispose2,checkDispose2 = res2.phase2 ctxt - let generate = - mkCompGenSequential m - (mkSequential sp m - (mkValSet spm vref e) - generate2) - // zero out the current value to free up its memory - (mkValSet m vref (mkDefault (m,vref.Type))) - let dispose = dispose2 - let checkDispose = checkDispose2 - generate,dispose,checkDispose) - stateVars = vref::res2.stateVars } + Some (RepresentBindingAsStateMachineLocal bind res2 m) + | None -> + None + + | Expr.LetRec(binds,e2,m,_) + when // Restriction: only limited forms of "let rec" in sequence expressions can be handled by assignment to state local values + + (let recvars = valsOfBinds binds |> List.map (fun v -> (v,0)) |> ValMap.OfList + binds |> List.forall (fun bind -> + // Rule 1 - IsCompiledAsTopLevel require no state local value + bind.Var.IsCompiledAsTopLevel || + // Rule 2 - funky constrained local funcs not allowed + not (IsGenericValWithGenericContraints g bind.Var)) && + binds |> List.count (fun bind -> + // Rule 3 - Recursive non-lambda and repack values are allowed + match stripExpr bind.Expr with + | Expr.Lambda _ + | Expr.TyLambda _ -> false + // "let v = otherv" bindings get produced for environment packing by InnerLambdasToTopLevelFuncs.fs, we can accept and compiler these ok + | Expr.Val(v,_,_) when not (recvars.ContainsVal v.Deref) -> false + | _ -> true) <= 1) -> + + match Lower 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 + let res3 = (res2,nonTopLevelBinds) ||> List.fold (fun acc bind -> RepresentBindingAsStateMachineLocal bind acc m) + // Represent the non-closure-capturing values as ordinary bindings on the expression. + let res4 = if topLevelBinds.IsEmpty then res3 else RepresentBindingsAsLifted (mkLetRecBinds m topLevelBinds) res3 + Some res4 | None -> None diff --git a/tests/fsharp/core/seq/test.fsx b/tests/fsharp/core/seq/test.fsx index cce6c3cb64d..ab6e84be36d 100644 --- a/tests/fsharp/core/seq/test.fsx +++ b/tests/fsharp/core/seq/test.fsx @@ -502,7 +502,204 @@ module Repro2 = do configure () /// The check is that the above code compiles OK +module InfiniteSequenceExpressionsExecuteWithFiniteResources = + let rec seqOneNonRecUnusedNonCapturing r = seq { + if r > 0 then + let recfun() = 1 + yield r + yield! seqOneNonRecUnusedNonCapturing r + } + + let rec seqOneNonRecNonCapturing r = seq { + if r > 0 then + let recfun x = if x > 0 then x else 2 + yield (recfun 3) + yield! seqOneNonRecNonCapturing r + } + + let rec seqOneNonRecCapturingOne r = seq { + if r > 0 then + let recfun x = if x > 0 then r else (x-1) + yield (recfun 3) + yield! seqOneNonRecCapturingOne r + } + let rec seqOneNonRecCapturingTwo r q = seq { + if r > 0 && q > 0 then + let recfun x = if x > 0 then (r,q) else (x-1, x-2) + yield (recfun 3) + yield! seqOneNonRecCapturingTwo r q + } + + let rec seqOneRecUnusedNonCapturing r = seq { + if r > 0 then + let rec recfun() = recfun() + yield r + yield! seqOneRecUnusedNonCapturing r + } + + let rec seqOneRecNonCapturing r = seq { + if r > 0 then + let rec recfun x = if x > 0 then x else recfun (x-1) + yield (recfun 3) + yield! seqOneRecNonCapturing r + } + + let rec seqOneRecCapturingOne r = seq { + if r > 0 then + let rec recfun x = if x > 0 then r else recfun (x-1) + yield (recfun 3) + yield! seqOneRecCapturingOne r + } + let rec seqOneRecCapturingTwo r q = seq { + if r > 0 && q > 0 then + let rec recfun x = if x > 0 then (r,q) else recfun (x-1) + yield (recfun 3) + yield! seqOneRecCapturingTwo r q + } + let rec seqTwoRecCapturingOne r = seq { + if r > 0 then + let rec recfun x = if x > 0 then r else recfun2 (x-1) + and recfun2 x = if x > 0 then r else recfun (x-1) + yield (recfun 3) + yield! seqTwoRecCapturingOne r + } + let rec seqThreeRecCapturingOne r = seq { + if r > 0 then + let rec recfun x = if x > 0 then r else recfun2 (x-1) + and recfun2 x = if x > 0 then r else recfun3 (x-1) + and recfun3 x = if x > 0 then r else recfun (x-1) + yield (recfun 3) + yield! seqThreeRecCapturingOne r + } + + // These tests will stackoverflow or out-of-memory if the above functions are not compiled to "sequence epression tailcalls", + // i.e. by compiling them to a state machine + let tests() = + printfn "starting seqOneUnusedNonCapturing" + check "celkecwecmkl" (Seq.item 10000000 (seqOneNonRecUnusedNonCapturing 1)) 1 + + printfn "starting seqOneRecNonCapturing" + check "celkecwecmkl2" (Seq.item 10000000 (seqOneNonRecNonCapturing 2)) 3 + + printfn "starting seqOneRecCapturingOne" + check "celkecwecmkl3" (Seq.item 10000000 (seqOneNonRecCapturingOne 2)) 2 + + printfn "starting seqOneRecCapturingTwo" + check "celkecwecmkl4" (Seq.item 10000000 (seqOneNonRecCapturingTwo 2 2)) (2,2) + + + printfn "starting seqOneUnusedNonCapturing" + check "celkecwecmkl" (Seq.item 10000000 (seqOneRecUnusedNonCapturing 1)) 1 + + printfn "starting seqOneRecNonCapturing" + check "celkecwecmkl2" (Seq.item 10000000 (seqOneRecNonCapturing 2)) 3 + + printfn "starting seqOneRecCapturingOne" + check "celkecwecmkl3" (Seq.item 10000000 (seqOneRecCapturingOne 2)) 2 + + printfn "starting seqOneRecCapturingTwo" + check "celkecwecmkl4" (Seq.item 10000000 (seqOneRecCapturingTwo 2 2)) (2,2) + + printfn "starting seqTwoRecCapturingOne" + check "celkecwecmkl5" (Seq.item 10000000 (seqTwoRecCapturingOne 2)) 2 + + printfn "starting seqThreeRecCapturingOne" + check "celkecwecmkl6" (Seq.item 10000000 (seqThreeRecCapturingOne 2)) 2 + + + // Note, recursively referential memoization is not compiled to use finite resources. If someone is using a recursive memoization table in this position + // of an infinite sequence expression then they are going to hit massive resource problems in any case... + (* + let memoize f = + let dict = System.Collections.Generic.Dictionary() + fun x -> if dict.ContainsKey x then dict.[x] else let res = f x in dict.[x] <- res; res + + // Capture 1 recursive memoizations + let rec seqOneRecCapturingOneWithOneMemoized r = seq { + if r > 0 then + let rec recfun = memoize (fun x -> if x > 0 then r else recfun (x-1)) + yield (recfun 3) + yield! seqOneRecCapturingOneWithOneMemoized r + } + + // Capture 1 recursive memoizations + let rec seqTwoRecCapturingOneWithOneMemoized r = seq { + if r > 0 then + let rec recfun = memoize (fun x -> if x > 0 then r else recfun2 (x-1)) + and recfun2 x = if x > 0 then r else recfun (x-1) + yield (recfun 3) + yield! seqTwoRecCapturingOneWithOneMemoized r + } + + + // Capture 1 recursive memoizations + let rec seqThreeRecCapturingOneWithOneMemoized r = seq { + if r > 0 then + let rec recfun = memoize (fun x -> if x > 0 then r else recfun2 (x-1)) + and recfun2 x = if x > 0 then r else recfun3 (x-1) + and recfun3 x = if x > 0 then r else recfun (x-1) + yield (recfun 3) + yield! seqThreeRecCapturingOneWithOneMemoized r + } + + // Capture 2 recursive memoizations + let rec seqThreeRecCapturingOneWithTwoMemoized r = seq { + if r > 0 then + let rec recfun = memoize (fun x -> if x > 0 then r else recfun2 (x-1)) + and recfun2 x = if x > 0 then r else recfun3 (x-1) + and recfun3 = memoize (fun x -> if x > 0 then r else recfun (x-1)) + yield (recfun 3) + yield! seqThreeRecCapturingOneWithTwoMemoized r + } + + // Capture 3 recursive memoizations + let syncLoopThreeRecCapturingWithThreeMemoized n r = + let rec recfun = memoize (fun x -> if x > 0 then r else recfun2 (x-1)) + and recfun2 = memoize (fun x -> if x > 0 then r else recfun3 (x-1)) + and recfun3 = memoize (fun x -> if x > 0 then r else recfun (x-1)) + let rec loop n = + if n > 0 then + recfun 3 |> ignore + loop (n-1) + else + recfun r + loop n + + + let rec seqThreeRecCapturingOneWithThreeMemoized r = seq { + if r > 0 then + let rec recfun = memoize (fun x -> if x > 0 then r else recfun2 (x-1)) + and recfun2 = memoize (fun x -> if x > 0 then r else recfun3 (x-1)) + and recfun3 = memoize (fun x -> if x > 0 then r else recfun (x-1)) + yield (recfun 3) + yield! seqThreeRecCapturingOneWithThreeMemoized r + } + + printfn "starting seqOneRecCapturingOneWithOneMemoized" + printfn "%i" (Seq.item 10000000 (seqOneRecCapturingOneWithOneMemoized 2)) + + printfn "starting seqTwoRecCapturingOneWithOneMemoized" + printfn "%i" (Seq.item 10000000 (seqTwoRecCapturingOneWithOneMemoized 2)) + + printfn "starting seqThreeRecCapturingOneWithOneMemoized" + printfn "%i" (Seq.item 10000000 (seqThreeRecCapturingOneWithOneMemoized 2)) + + + printfn "starting seqThreeRecCapturingOneWithTwoMemoized" + printfn "%i" (Seq.item 10000000 (seqThreeRecCapturingOneWithTwoMemoized 2)) + + printfn "starting syncLoopThreeRecCapturingWithThreeMemoized" + printfn "%i" (syncLoopThreeRecCapturingWithThreeMemoized 10000000 2) + + printfn "starting seqThreeRecCapturingOneWithThreeMemoized" + printfn "%i" (Seq.item 10000000 (seqThreeRecCapturingOneWithThreeMemoized 2)) + + *) + +InfiniteSequenceExpressionsExecuteWithFiniteResources.tests() + + (*--------------------------------------------------------------------------- !* wrap up *--------------------------------------------------------------------------- *)