Integrate with VisualFSharp

Author: rojepp

src/fsharp/CompileOptions.fs

@@ -1133,17 +1133,17 @@ let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importM
     let optEnv0 = optEnv
     let (TAssembly(implFiles)) = tassembly
     ReportTime tcConfig ("Optimizations");
-    let results,(optEnvFirstLoop,_,_) = 
-        ((optEnv0,optEnv0,optEnv0),implFiles) ||> List.mapFold (fun (optEnvFirstLoop,optEnvExtraLoop,optEnvFinalSimplify) implFile -> 
+    let results,(optEnvFirstLoop,_,_,_) = 
+        ((optEnv0,optEnv0,optEnv0,SignatureHidingInfo.Empty),implFiles) ||> List.mapFold (fun (optEnvFirstLoop,optEnvExtraLoop,optEnvFinalSimplify,hidden) implFile -> 
 
             // Only do abstract_big_targets on the first pass!  Only do it when TLR is on!  
             let optSettings = tcConfig.optSettings 
             let optSettings = { optSettings with abstractBigTargets = tcConfig.doTLR }
             let optSettings = { optSettings with reportingPhase = true }
 
             //ReportTime tcConfig ("Initial simplify");
-            let optEnvFirstLoop,implFile,implFileOptData = 
-                Optimizer.OptimizeImplFile(optSettings,ccu,tcGlobals,tcVal, importMap,optEnvFirstLoop,isIncrementalFragment,tcConfig.emitTailcalls,implFile)
+            let optEnvFirstLoop,implFile,implFileOptData,hidden = 
+                Optimizer.OptimizeImplFile(optSettings,ccu,tcGlobals,tcVal, importMap,optEnvFirstLoop,isIncrementalFragment,tcConfig.emitTailcalls,hidden,implFile)
 
             let implFile = AutoBox.TransformImplFile tcGlobals importMap implFile 
 
@@ -1157,7 +1157,7 @@ let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importM
             let implFile,optEnvExtraLoop = 
                 if tcConfig.extraOptimizationIterations > 0 then 
                     //ReportTime tcConfig ("Extra simplification loop");
-                    let optEnvExtraLoop,implFile, _ = Optimizer.OptimizeImplFile(optSettings,ccu,tcGlobals,tcVal, importMap,optEnvExtraLoop,isIncrementalFragment,tcConfig.emitTailcalls,implFile)
+                    let optEnvExtraLoop,implFile, _, _ = Optimizer.OptimizeImplFile(optSettings,ccu,tcGlobals,tcVal, importMap,optEnvExtraLoop,isIncrementalFragment,tcConfig.emitTailcalls,hidden,implFile)
                     //PrintWholeAssemblyImplementation tcConfig outfile (sprintf "extra-loop-%d" n) implFile;
                     implFile,optEnvExtraLoop
                 else
@@ -1182,12 +1182,12 @@ let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importM
             let implFile,optEnvFinalSimplify =
                 if tcConfig.doFinalSimplify then 
                     //ReportTime tcConfig ("Final simplify pass");
-                    let optEnvFinalSimplify,implFile, _ = Optimizer.OptimizeImplFile(optSettings,ccu,tcGlobals,tcVal, importMap,optEnvFinalSimplify,isIncrementalFragment,tcConfig.emitTailcalls,implFile)
+                    let optEnvFinalSimplify,implFile, _, _ = Optimizer.OptimizeImplFile(optSettings,ccu,tcGlobals,tcVal, importMap,optEnvFinalSimplify,isIncrementalFragment,tcConfig.emitTailcalls,hidden,implFile)
                     //PrintWholeAssemblyImplementation tcConfig outfile "post-rec-opt" implFile;
                     implFile,optEnvFinalSimplify 
                 else 
                     implFile,optEnvFinalSimplify 
-            (implFile,implFileOptData),(optEnvFirstLoop,optEnvExtraLoop,optEnvFinalSimplify))
+            (implFile,implFileOptData),(optEnvFirstLoop,optEnvExtraLoop,optEnvFinalSimplify,hidden))
 
     let implFiles,implFileOptDatas = List.unzip results
     let assemblyOptData = Optimizer.UnionOptimizationInfos implFileOptDatas

src/fsharp/FSComp.txt

@@ -1344,3 +1344,4 @@ estApplyStaticArgumentsForMethodNotImplemented,"A type provider implemented GetS
 3187,checkNotSufficientlyGenericBecauseOfScope,"Type inference caused the type variable %s to escape its scope. Consider adding an explicit type parameter declaration or adjusting your code to be less generic."
 3188,checkNotSufficientlyGenericBecauseOfScopeAnon,"Type inference caused an inference type variable to escape its scope. Consider adding type annotations to make your code less generic."
 3189,checkRaiseFamilyFunctionArgumentCount,"Redundant arguments are being ignored in function '%s'. Expected %d but got %d arguments."
+3190,checkLowercaseLiteralBindingInPattern,"Lowercase literal '%s' is being shadowed by a new pattern with the same name. Only uppercase and module-prefixed literals can be used as named patterns."

src/fsharp/LexFilter.fs

@@ -403,12 +403,18 @@ type LexbufState(startPos: Position,
     member x.EndPos = endPos
     member x.PastEOF = pastEOF
 
+[<Struct>]
+type PositionTuple =
+    val X: Position
+    val Y: Position
+    new (x: Position, y: Position) = { X = x; Y = y }
+
 /// Used to save the state related to a token
 [<Class>]
 type TokenTup = 
     val Token : token
     val LexbufState : LexbufState
-    val LastTokenPos: Position * Position
+    val LastTokenPos: PositionTuple
     new (token,state,lastTokenPos) = { Token=token; LexbufState=state;LastTokenPos=lastTokenPos }
 
     /// Returns starting position of the token
@@ -485,6 +491,12 @@ let (|TyparsCloseOp|_|) (txt:string) =
               | _ -> None
     Some([| for _c in angles do yield GREATER |],afterOp)
 
+[<Struct>]
+type PositionWithColumn =
+    val Position: Position
+    val Column: int
+    new (position: Position, column: int) = { Position = position; Column = column }
+
 //----------------------------------------------------------------------------
 // build a LexFilter
 //--------------------------------------------------------------------------*)
@@ -553,7 +565,7 @@ type LexFilterImpl (lightSyntaxStatus:LightSyntaxStatus, compilingFsLib, lexer,
         let tokenLexbufState = getLexbufState()
         savedLexbufState <- tokenLexbufState
         haveLexbufState <- true
-        TokenTup(token,tokenLexbufState,(lastTokenStart,lastTokenEnd))
+        TokenTup(token,tokenLexbufState,PositionTuple(lastTokenStart,lastTokenEnd))
 
     //----------------------------------------------------------------------------
     // Fetch a raw token, either from the old lexer or from our delayedStack
@@ -623,7 +635,7 @@ type LexFilterImpl (lightSyntaxStatus:LightSyntaxStatus, compilingFsLib, lexer,
     let pushCtxt tokenTup (newCtxt:Context) =
         let rec unindentationLimit strict stack = 
             match newCtxt,stack with 
-            | _, [] -> (newCtxt.StartPos, -1) 
+            | _, [] -> PositionWithColumn(newCtxt.StartPos, -1) 
 
             // ignore Vanilla because a SeqBlock is always coming 
             | _, (CtxtVanilla _ :: rest) -> unindentationLimit strict rest
@@ -635,8 +647,8 @@ type LexFilterImpl (lightSyntaxStatus:LightSyntaxStatus, compilingFsLib, lexer,
             // '(match' limited by minimum of two  
             | _,(((CtxtMatch _) as ctxt1) :: CtxtSeqBlock _ :: (CtxtParen ((BEGIN | LPAREN),_) as ctxt2) :: _rest)
                       -> if ctxt1.StartCol <= ctxt2.StartCol 
-                         then (ctxt1.StartPos,ctxt1.StartCol) 
-                         else (ctxt2.StartPos,ctxt2.StartCol) 
+                         then PositionWithColumn(ctxt1.StartPos,ctxt1.StartCol) 
+                         else PositionWithColumn(ctxt2.StartPos,ctxt2.StartCol) 
 
              // 'let ... = function' limited by 'let', precisely  
              // This covers the common form 
@@ -645,15 +657,15 @@ type LexFilterImpl (lightSyntaxStatus:LightSyntaxStatus, compilingFsLib, lexer,
              //     | Case1 -> ...       
              //     | Case2 -> ...       
             | (CtxtMatchClauses _), (CtxtFunction _ :: CtxtSeqBlock _ :: (CtxtLetDecl  _ as limitCtxt) :: _rest)
-                      -> (limitCtxt.StartPos,limitCtxt.StartCol)
+                      -> PositionWithColumn(limitCtxt.StartPos,limitCtxt.StartCol)
 
             // Otherwise 'function ...' places no limit until we hit a CtxtLetDecl etc...  (Recursive) 
             | (CtxtMatchClauses _), (CtxtFunction _ :: rest)
                       -> unindentationLimit false rest
 
             // 'try ... with'  limited by 'try'  
             | _,(CtxtMatchClauses _ :: (CtxtTry _ as limitCtxt) :: _rest)
-                      -> (limitCtxt.StartPos,limitCtxt.StartCol)
+                      -> PositionWithColumn(limitCtxt.StartPos,limitCtxt.StartCol)
 
             // 'fun ->' places no limit until we hit a CtxtLetDecl etc...  (Recursive) 
             | _,(CtxtFun _ :: rest)
@@ -672,7 +684,7 @@ type LexFilterImpl (lightSyntaxStatus:LightSyntaxStatus, compilingFsLib, lexer,
             // This is a serious thing to allow, but is required since there is no "return" in this language.
             // Without it there is no way of escaping special cases in large bits of code without indenting the main case.
             | CtxtSeqBlock _, (CtxtElse _  :: (CtxtIf _ as limitCtxt) :: _rest) 
-                      -> (limitCtxt.StartPos,limitCtxt.StartCol)
+                      -> PositionWithColumn(limitCtxt.StartPos,limitCtxt.StartCol)
 
             // Permitted inner-construct precise block alighnment: 
             //           interface ...
@@ -683,7 +695,7 @@ type LexFilterImpl (lightSyntaxStatus:LightSyntaxStatus, compilingFsLib, lexer,
             //           with ... 
             //           end 
             | CtxtWithAsAugment _,((CtxtInterfaceHead _ | CtxtMemberHead _ | CtxtException _ | CtxtTypeDefns _) as limitCtxt  :: _rest)
-                      -> (limitCtxt.StartPos,limitCtxt.StartCol) 
+                      -> PositionWithColumn(limitCtxt.StartPos,limitCtxt.StartCol) 
 
             // Permit unindentation via parentheses (or begin/end) following a 'then', 'else' or 'do':
             //        if nr > 0 then (  
@@ -754,12 +766,12 @@ type LexFilterImpl (lightSyntaxStatus:LightSyntaxStatus, compilingFsLib, lexer,
             // 'type C = interface ... '       limited by 'type' 
             // 'type C = struct ... '       limited by 'type' 
             | _,(CtxtParen ((CLASS | STRUCT | INTERFACE),_) :: CtxtSeqBlock _ :: (CtxtTypeDefns _ as limitCtxt) ::  _)
-                      -> (limitCtxt.StartPos,limitCtxt.StartCol + 1) 
+                      -> PositionWithColumn(limitCtxt.StartPos,limitCtxt.StartCol + 1) 
 
             // REVIEW: document these 
             | _,(CtxtSeqBlock _ :: CtxtParen((BEGIN | LPAREN | LBRACK | LBRACK_BAR),_) :: CtxtVanilla _ :: (CtxtSeqBlock _ as limitCtxt) :: _)
             | (CtxtSeqBlock _),(CtxtParen ((BEGIN | LPAREN | LBRACE | LBRACK | LBRACK_BAR)      ,_) :: CtxtSeqBlock _ :: ((CtxtTypeDefns _ | CtxtLetDecl _ | CtxtMemberBody _ | CtxtWithAsLet _) as limitCtxt) ::  _)
-                      -> (limitCtxt.StartPos,limitCtxt.StartCol + 1) 
+                      -> PositionWithColumn(limitCtxt.StartPos,limitCtxt.StartCol + 1) 
 
             // Permitted inner-construct (e.g. "then" block and "else" block in overall 
             // "if-then-else" block ) block alighnment: 
@@ -768,34 +780,34 @@ type LexFilterImpl (lightSyntaxStatus:LightSyntaxStatus, compilingFsLib, lexer,
             //           elif expr  
             //           else expr  
             | (CtxtIf   _ | CtxtElse _ | CtxtThen _), (CtxtIf _ as limitCtxt) :: _rest  
-                      -> (limitCtxt.StartPos,limitCtxt.StartCol)
+                      -> PositionWithColumn(limitCtxt.StartPos,limitCtxt.StartCol)
             // Permitted inner-construct precise block alighnment: 
             //           while  ... 
             //           do expr
             //           done   
             | (CtxtDo _), ((CtxtFor  _ | CtxtWhile _) as limitCtxt) :: _rest  
-                      -> (limitCtxt.StartPos,limitCtxt.StartCol)
+                      -> PositionWithColumn(limitCtxt.StartPos,limitCtxt.StartCol)
 
 
             // These contexts all require indentation by at least one space 
             | _,((CtxtInterfaceHead _ | CtxtNamespaceHead _ | CtxtModuleHead _ | CtxtException _ | CtxtModuleBody (_,false) | CtxtIf _ | CtxtWithAsLet _ | CtxtLetDecl _ | CtxtMemberHead _ | CtxtMemberBody _) as limitCtxt :: _) 
-                      -> (limitCtxt.StartPos,limitCtxt.StartCol + 1) 
+                      -> PositionWithColumn(limitCtxt.StartPos,limitCtxt.StartCol + 1) 
 
             // These contexts can have their contents exactly aligning 
             | _,((CtxtParen _ | CtxtFor _ | CtxtWhen _ | CtxtWhile _ | CtxtTypeDefns _ | CtxtMatch _  | CtxtModuleBody (_,true) | CtxtNamespaceBody _ | CtxtTry _ | CtxtMatchClauses _ | CtxtSeqBlock _) as limitCtxt :: _)
-                      -> (limitCtxt.StartPos,limitCtxt.StartCol) 
+                      -> PositionWithColumn(limitCtxt.StartPos,limitCtxt.StartCol) 
 
         match newCtxt with 
         // Don't bother to check pushes of Vanilla blocks since we've 
         // always already pushed a SeqBlock at this position.
         | CtxtVanilla _ -> ()
         | _ -> 
-            let p1,c1 = unindentationLimit true offsideStack
+            let p1 = unindentationLimit true offsideStack
             let c2 = newCtxt.StartCol
-            if c2 < c1 then 
+            if c2 < p1.Column then 
                 warn tokenTup 
-                       (if debug then (sprintf "possible incorrect indentation: this token is offside of context at position %s, newCtxt = %A, stack = %A, newCtxtPos = %s, c1 = %d, c2 = %d" (warningStringOfPos p1) newCtxt offsideStack (stringOfPos (newCtxt.StartPos)) c1 c2)  
-                        else          (FSComp.SR.lexfltTokenIsOffsideOfContextStartedEarlier(warningStringOfPos p1))    )
+                       (if debug then (sprintf "possible incorrect indentation: this token is offside of context at position %s, newCtxt = %A, stack = %A, newCtxtPos = %s, c1 = %d, c2 = %d" (warningStringOfPos p1.Position) newCtxt offsideStack (stringOfPos (newCtxt.StartPos)) p1.Column c2)  
+                        else          (FSComp.SR.lexfltTokenIsOffsideOfContextStartedEarlier(warningStringOfPos p1.Position))    )
         let newOffsideStack = newCtxt :: offsideStack
         if debug then dprintf "--> pushing, stack = %A\n" newOffsideStack
         offsideStack <- newOffsideStack
@@ -1042,7 +1054,7 @@ type LexFilterImpl (lightSyntaxStatus:LightSyntaxStatus, compilingFsLib, lexer,
             // span of inserted token lasts from the col + 1 of the prev token 
             // to the beginning of current token
             let lastTokenPos = 
-                let pos = snd tokenTup.LastTokenPos
+                let pos = tokenTup.LastTokenPos.Y
                 pos.ShiftColumnBy 1
             returnToken (lexbufStateForInsertedDummyTokens (lastTokenPos, tokenTup.LexbufState.StartPos)) tok
 
@@ -2151,7 +2163,7 @@ type LexFilterImpl (lightSyntaxStatus:LightSyntaxStatus, compilingFsLib, lexer,
                        | PERCENT_OP s -> (s = "%") || (s = "%%") 
                        | _ -> true) &&
                       nextTokenIsAdjacent tokenTup && 
-                      not (prevWasAtomicEnd && (snd(tokenTup.LastTokenPos) = startPosOfTokenTup tokenTup))) ->
+                      not (prevWasAtomicEnd && (tokenTup.LastTokenPos.Y = startPosOfTokenTup tokenTup))) ->
 
               let plus = 
                   match tokenTup.Token with 

src/fsharp/NameResolution.fs

@@ -606,7 +606,10 @@ let private AddPartsOfTyconRefToNameEnv bulkAddMode ownDefinition (g:TcGlobals)
         ePatItems = ePatItems
         eIndexedExtensionMembers = eIndexedExtensionMembers 
         eUnindexedExtensionMembers = eUnindexedExtensionMembers }
-    
+
+let TryFindPatternByName name {ePatItems = patternMap} =
+    NameMap.tryFind name patternMap
+
 /// Add a set of type definitions to the name resolution environment 
 let AddTyconRefsToNameEnv bulkAddMode ownDefinition g amap m  root nenv tcrefs = 
     let env = List.fold (AddPartsOfTyconRefToNameEnv bulkAddMode ownDefinition g amap m) nenv tcrefs

src/fsharp/NameResolution.fsi

@@ -101,6 +101,9 @@ type FullyQualifiedFlag =
 [<RequireQualifiedAccess>]
 type BulkAdd = Yes | No
 
+/// Lookup patterns in name resolution environment
+val internal TryFindPatternByName : string -> NameResolutionEnv -> Item option
+
 /// Add extra items to the environment for Visual Studio, e.g. static members 
 val internal AddFakeNamedValRefToNameEnv : string -> NameResolutionEnv -> ValRef -> NameResolutionEnv
 

src/fsharp/Optimizer.fs

@@ -3193,7 +3193,7 @@ and OptimizeModuleDefs cenv (env,bindInfosColl) defs =
     let defs,minfos = List.unzip defs
     (defs,UnionOptimizationInfos minfos),(env,bindInfosColl)
 
-and OptimizeImplFileInternal cenv env isIncrementalFragment (TImplFile(qname, pragmas, (ModuleOrNamespaceExprWithSig(mty,_,_) as mexpr), hasExplicitEntryPoint,isScript)) =
+and OptimizeImplFileInternal cenv env isIncrementalFragment hidden (TImplFile(qname, pragmas, (ModuleOrNamespaceExprWithSig(mty,_,_) as mexpr), hasExplicitEntryPoint,isScript)) =
     let env,mexpr',minfo  = 
         match mexpr with 
         // FSI: FSI compiles everything as if you're typing incrementally into one module 
@@ -3209,16 +3209,16 @@ and OptimizeImplFileInternal cenv env isIncrementalFragment (TImplFile(qname, pr
             let env = { env with localExternalVals=env.localExternalVals.MarkAsCollapsible() } // take the chance to flatten to a dictionary
             env, mexpr', minfo
 
-    let hidden = ComputeHidingInfoAtAssemblyBoundary mty
+    let hidden = ComputeHidingInfoAtAssemblyBoundary mty hidden
 
     let minfo = AbstractLazyModulInfoByHiding true hidden minfo
-    env, TImplFile(qname,pragmas,mexpr',hasExplicitEntryPoint,isScript), minfo
+    env, TImplFile(qname,pragmas,mexpr',hasExplicitEntryPoint,isScript), minfo, hidden
 
 //-------------------------------------------------------------------------
 // Entry point
 //------------------------------------------------------------------------- 
 
-let OptimizeImplFile(settings,ccu,tcGlobals,tcVal, importMap,optEnv,isIncrementalFragment,emitTailcalls,mimpls) =
+let OptimizeImplFile(settings,ccu,tcGlobals,tcVal, importMap,optEnv,isIncrementalFragment,emitTailcalls,hidden,mimpls) =
     let cenv = 
         { settings=settings;
           scope=ccu; 
@@ -3229,7 +3229,7 @@ let OptimizeImplFile(settings,ccu,tcGlobals,tcVal, importMap,optEnv,isIncrementa
           localInternalVals=new System.Collections.Generic.Dictionary<Stamp,ValInfo>(10000);
           emitTailcalls=emitTailcalls;
           casApplied=new Dictionary<Stamp,bool>() }
-    OptimizeImplFileInternal cenv optEnv isIncrementalFragment mimpls 
+    OptimizeImplFileInternal cenv optEnv isIncrementalFragment hidden mimpls  
 
 
 //-------------------------------------------------------------------------

src/fsharp/Optimizer.fsi

@@ -5,6 +5,7 @@ module internal Microsoft.FSharp.Compiler.Optimizer
 open Internal.Utilities
 open Microsoft.FSharp.Compiler 
 open Microsoft.FSharp.Compiler.Tast
+open Microsoft.FSharp.Compiler.Tastops
 open Microsoft.FSharp.Compiler.TcGlobals 
 open Microsoft.FSharp.Compiler.AbstractIL 
 open Microsoft.FSharp.Compiler.AbstractIL.Internal 
@@ -43,7 +44,7 @@ type IncrementalOptimizationEnv =
 val internal BindCcu : CcuThunk -> CcuOptimizationInfo -> IncrementalOptimizationEnv -> TcGlobals -> IncrementalOptimizationEnv
 
 /// Optimize one implementation file in the given environment
-val internal OptimizeImplFile : OptimizationSettings *  CcuThunk * TcGlobals * ConstraintSolver.TcValF * Import.ImportMap * IncrementalOptimizationEnv * isIncrementalFragment: bool * emitTaicalls: bool * TypedImplFile -> IncrementalOptimizationEnv * TypedImplFile * ImplFileOptimizationInfo
+val internal OptimizeImplFile : OptimizationSettings *  CcuThunk * TcGlobals * ConstraintSolver.TcValF * Import.ImportMap * IncrementalOptimizationEnv * isIncrementalFragment: bool * emitTaicalls: bool * SignatureHidingInfo * TypedImplFile -> IncrementalOptimizationEnv * TypedImplFile * ImplFileOptimizationInfo * SignatureHidingInfo
 
 #if DEBUG
 /// Displaying optimization data