Merge branch 'fix-742' of https://github.com/dsyme/visualfsharp into …

…dsyme-fix-742
dotnet · Dec 4, 2015 · c1e0bc8 · c1e0bc8
2 parents 21971fb + 261732c
commit c1e0bc8
Show file tree

Hide file tree

Showing 4 changed files with 134 additions and 73 deletions.
diff --git a/README.md b/README.md
@@ -57,6 +57,8 @@ For F# 4.0 development
 
 Guidelines for contributions to the Visual F# compiler, library, and tools can be found [here](CONTRIBUTING.md).
 
+How we label issues and PRs:  https://github.com/dotnet/roslyn/wiki/Labels-used-for-issues  
+
 If you would like to contribute to the F# ecosystem more generally, please see the F# Software Foundation's [Community Projects](http://fsharp.org/community/projects/) pages.
 
 ###Code Flow to Other Platforms

diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs
@@ -7748,86 +7748,120 @@ let (|RangeInt32Step|_|) g expr =
 
     | _ -> None
 
-let (|ExtractTypeOfExpr|_|) g expr = Some (tyOfExpr g expr)
+let (|GetEnumeratorCall|_|) expr =   
+    match expr with   
+    | Expr.Op (TOp.ILCall( _,  _,  _,  _,  _,  _, _, iLMethodRef,  _,  _,  _),_,[Expr.Val(vref,_,_) | Expr.Op(_, _, [Expr.Val(vref, ValUseFlag.NormalValUse, _)], _) ],_) ->  
+        if iLMethodRef.Name = "GetEnumerator" then Some(vref)  
+        else None  
+    | _ -> None  
+
+let (|CompiledForEachExpr|_|) g expr =   
+    match expr with
+    | Let (enumerableVar, enumerableExpr, _,
+           Let (enumeratorVar, GetEnumeratorCall enumerableVar2, enumeratorBind,
+              TryFinally (WhileLoopForCompiledForEachExpr (_, Let (elemVar,_,_,bodyExpr), _), _))) 
+                 // Apply correctness conditions to ensure this really is a compiled for-each expression.
+                 when valRefEq g (mkLocalValRef enumerableVar) enumerableVar2 &&
+                      enumerableVar.IsCompilerGenerated &&
+                      enumeratorVar.IsCompilerGenerated &&
+                      let fvs = (freeInExpr CollectLocals bodyExpr)
+                      not (Zset.contains enumerableVar fvs.FreeLocals) && 
+                      not (Zset.contains enumeratorVar fvs.FreeLocals) ->
+
+        // Extract useful ranges
+        let m = enumerableExpr.Range
+        let mBody = bodyExpr.Range
+
+        let spForLoop,mForLoop = match enumeratorBind with SequencePointAtBinding(spStart) -> SequencePointAtForLoop(spStart),spStart  |  _ -> NoSequencePointAtForLoop,m
+        let spWhileLoop   = match enumeratorBind with SequencePointAtBinding(spStart) -> SequencePointAtWhileLoop(spStart)|  _ -> NoSequencePointAtWhileLoop
+        let enumerableTy = tyOfExpr g enumerableExpr
+
+        Some (enumerableTy, enumerableExpr, elemVar, bodyExpr, (m, mBody, spForLoop, mForLoop, spWhileLoop))
+    | _ -> None  
+
+
+let (|CompiledInt32RangeForEachExpr|_|) g expr = 
+    match expr with
+    | CompiledForEachExpr g (_, RangeInt32Step g (startExpr, step, finishExpr), elemVar, bodyExpr, ranges) ->
+        Some (startExpr, step, finishExpr, elemVar, bodyExpr, ranges)
+        | _ -> None
+    | _ -> None
+
 
 type OptimizeForExpressionOptions = OptimizeIntRangesOnly | OptimizeAllForExpressions
 
 let DetectAndOptimizeForExpression g option expr =
-    match expr with
-    | Let (_, enumerableExpr, _,
-           Let (_, _, enumeratorBind,
-              TryFinally (WhileLoopForCompiledForEachExpr (_, Let (elemVar,_,_,bodyExpr), _), _))) ->
-
-      let m = enumerableExpr.Range
-      let mBody = bodyExpr.Range
-
-      let spForLoop,mForLoop = match enumeratorBind with SequencePointAtBinding(spStart) -> SequencePointAtForLoop(spStart),spStart  |  _ -> NoSequencePointAtForLoop,m
-      let spWhileLoop   = match enumeratorBind with SequencePointAtBinding(spStart) -> SequencePointAtWhileLoop(spStart)|  _ -> NoSequencePointAtWhileLoop
-
-      match option,enumerableExpr with
-      | _,RangeInt32Step g (startExpr, step, finishExpr) ->
-        match step with
-        | -1 | 1  ->
-            mkFastForLoop  g (spForLoop,m,elemVar,startExpr,(step = 1),finishExpr,bodyExpr)
-        | _ -> expr
-      | OptimizeAllForExpressions,ExtractTypeOfExpr g ty when isStringTy g ty ->
-        // type is string, optimize for expression as:
-        //  let $str = enumerable
-        //  for $idx in 0..(str.Length - 1) do
-        //      let elem = str.[idx]
-        //      body elem
-
-        let strVar      ,strExpr    = mkCompGenLocal m "str" ty
-        let idxVar      ,idxExpr    = mkCompGenLocal m "idx" g.int32_ty
-
-        let lengthExpr              = mkGetStringLength g m strExpr
-        let charExpr                = mkGetStringChar g m strExpr idxExpr
-
-        let startExpr               = mkZero g m
-        let finishExpr              = mkDecr g mForLoop lengthExpr
-        let loopItemExpr            = mkCoerceIfNeeded g elemVar.Type g.char_ty charExpr  // for compat reasons, loop item over string is sometimes object, not char
-        let bodyExpr                = mkCompGenLet mBody elemVar loopItemExpr bodyExpr
-        let forExpr                 = mkFastForLoop g (spForLoop,m,idxVar,startExpr,true,finishExpr,bodyExpr)
-        let expr                    = mkCompGenLet m strVar enumerableExpr forExpr
-
-        expr
-      | OptimizeAllForExpressions,ExtractTypeOfExpr g ty when isListTy g ty ->
-        // type is list, optimize for expression as:
-        //  let mutable $currentVar = listExpr
-        //  let mutable $nextVar    = $tailOrNull
-        //  while $guardExpr do
-        //    let i = $headExpr
-        //    bodyExpr ()
-        //    $current   <- $next
-        //    $next      <- $tailOrNull
-
-        let IndexHead                   = 0
-        let IndexTail                   = 1
-
-        let currentVar  ,currentExpr    = mkMutableCompGenLocal m "current" ty
-        let nextVar     ,nextExpr       = mkMutableCompGenLocal m "next" ty
-        let elemTy                      = destListTy g ty
-
-        let guardExpr                   = mkNonNullTest g m nextExpr
-        let headOrDefaultExpr           = mkUnionCaseFieldGetUnproven(currentExpr,g.cons_ucref,[elemTy],IndexHead,m)
-        let tailOrNullExpr              = mkUnionCaseFieldGetUnproven(currentExpr,g.cons_ucref,[elemTy],IndexTail,mBody)
-        let bodyExpr                    =
-            mkCompGenLet m elemVar headOrDefaultExpr
-                (mkCompGenSequential mBody
-                    bodyExpr
+    match option, expr with
+    | _, CompiledInt32RangeForEachExpr g (startExpr, (1 | -1 as step), finishExpr, elemVar, bodyExpr, ranges) -> 
+
+           let (m, _mBody, spForLoop, _mForLoop, _spWhileLoop) = ranges
+           mkFastForLoop  g (spForLoop,m,elemVar,startExpr,(step = 1),finishExpr,bodyExpr)
+
+    | OptimizeAllForExpressions,CompiledForEachExpr g (enumerableTy, enumerableExpr, elemVar, bodyExpr, ranges) ->
+
+         let (m, mBody, spForLoop, mForLoop, spWhileLoop) = ranges
+
+         if isStringTy g enumerableTy then
+            // type is string, optimize for expression as:
+            //  let $str = enumerable
+            //  for $idx in 0..(str.Length - 1) do
+            //      let elem = str.[idx]
+            //      body elem
+
+            let strVar      ,strExpr    = mkCompGenLocal m "str" enumerableTy
+            let idxVar      ,idxExpr    = mkCompGenLocal m "idx" g.int32_ty
+
+            let lengthExpr              = mkGetStringLength g m strExpr
+            let charExpr                = mkGetStringChar g m strExpr idxExpr
+
+            let startExpr               = mkZero g m
+            let finishExpr              = mkDecr g mForLoop lengthExpr
+            let loopItemExpr            = mkCoerceIfNeeded g elemVar.Type g.char_ty charExpr  // for compat reasons, loop item over string is sometimes object, not char
+            let bodyExpr                = mkCompGenLet mBody elemVar loopItemExpr bodyExpr
+            let forExpr                 = mkFastForLoop g (spForLoop,m,idxVar,startExpr,true,finishExpr,bodyExpr)
+            let expr                    = mkCompGenLet m strVar enumerableExpr forExpr
+
+            expr
+
+         elif isListTy g enumerableTy then
+            // type is list, optimize for expression as:
+            //  let mutable $currentVar = listExpr
+            //  let mutable $nextVar    = $tailOrNull
+            //  while $guardExpr do
+            //    let i = $headExpr
+            //    bodyExpr ()
+            //    $current   <- $next
+            //    $next      <- $tailOrNull
+
+            let IndexHead                   = 0
+            let IndexTail                   = 1
+
+            let currentVar  ,currentExpr    = mkMutableCompGenLocal m "current" enumerableTy
+            let nextVar     ,nextExpr       = mkMutableCompGenLocal m "next" enumerableTy
+            let elemTy                      = destListTy g enumerableTy
+
+            let guardExpr                   = mkNonNullTest g m nextExpr
+            let headOrDefaultExpr           = mkUnionCaseFieldGetUnproven(currentExpr,g.cons_ucref,[elemTy],IndexHead,m)
+            let tailOrNullExpr              = mkUnionCaseFieldGetUnproven(currentExpr,g.cons_ucref,[elemTy],IndexTail,mBody)
+            let bodyExpr                    =
+                mkCompGenLet m elemVar headOrDefaultExpr
                     (mkCompGenSequential mBody
-                        (mkValSet mBody (mkLocalValRef currentVar) nextExpr)
-                        (mkValSet mBody (mkLocalValRef nextVar) tailOrNullExpr)
+                        bodyExpr
+                        (mkCompGenSequential mBody
+                            (mkValSet mBody (mkLocalValRef currentVar) nextExpr)
+                            (mkValSet mBody (mkLocalValRef nextVar) tailOrNullExpr)
+                        )
                     )
-                )
-        let whileExpr                   = mkWhile g (spWhileLoop, WhileLoopForCompiledForEachExprMarker, guardExpr, bodyExpr, m)
+            let whileExpr                   = mkWhile g (spWhileLoop, WhileLoopForCompiledForEachExprMarker, guardExpr, bodyExpr, m)
 
-        let expr =
-            mkCompGenLet m currentVar enumerableExpr
-                (mkCompGenLet m nextVar tailOrNullExpr whileExpr)
+            let expr =
+                mkCompGenLet m currentVar enumerableExpr
+                    (mkCompGenLet m nextVar tailOrNullExpr whileExpr)
 
-        expr
-      | _ -> expr
+            expr
+
+         else
+            expr
     | _ -> expr
 
 // Used to remove Expr.Link for inner expressions in pattern matches

diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs
@@ -6511,7 +6511,7 @@ and TcForEachExpr cenv overallTy env tpenv (pat,enumSynExpr,body,m,spForLoop)  =
         // Build iteration as a while loop with a try/finally disposal
         | Choice3Of3(enumerableVar,enumeratorVar, _,getEnumExpr,_,guardExpr,currentExpr) -> 
 
-            // This compiled for must be matched EXACTLY by DetectFastIntegerForLoops in opt.fs and creflect.fs
+            // This compiled for must be matched EXACTLY by CompiledForEachExpr in opt.fs and creflect.fs
             mkCompGenLet enumExpr.Range enumerableVar enumExpr
               (let cleanupE = BuildDisposableCleanup cenv env m enumeratorVar
                let spBind = (match spForLoop with SequencePointAtForLoop(spStart) -> SequencePointAtBinding(spStart) | NoSequencePointAtForLoop -> NoSequencePointAtStickyBinding)

diff --git a/tests/fsharp/core/seq/test.fsx b/tests/fsharp/core/seq/test.fsx
@@ -487,6 +487,31 @@ check "hfhdfsjkfur34"
         Failure "ss!!!" -> results := "caught"::!results
     !results)
     ["caught";"ssDispose";"eDispose"]
+
+// Check https://github.com/Microsoft/visualfsharp/pull/742
+
+module Repro1 = 
+
+    let configure () =
+     let aSequence = seq { yield "" } 
+     let aString = new string('a',3)
+     for _ in aSequence do
+       System.Console.WriteLine(aString)
+
+    do configure ()
+    /// The check is that the above code compiles OK
+
+module Repro2 = 
+
+    let configure () =
+     let aSequence = Microsoft.FSharp.Core.Operators.(..) 3 4
+     let aString = new string('a',3)
+     for _ in aSequence do
+       System.Console.WriteLine(aString)
+
+    do configure ()
+    /// The check is that the above code compiles OK
+
 
 (*---------------------------------------------------------------------------
 !* wrap up