X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnBinds.lhs;h=ced653a84e8a67973618dbb3fd83b637e2020fb3;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=a96d3ee5ad495550603bbb7870875ea6ee5caa86;hpb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;p=ghc-hetmet.git

diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs
index a96d3ee..ced653a 100644
--- a/ghc/compiler/rename/RnBinds.lhs
+++ b/ghc/compiler/rename/RnBinds.lhs
@@ -15,8 +15,8 @@ module RnBinds (
 	rnTopBinds,
 	rnMethodBinds,
 	rnBinds,
-	FreeVars(..),
-	DefinedVars(..)
+	SYN_IE(FreeVars),
+	SYN_IE(DefinedVars)
    ) where
 
 IMP_Ubiq()
@@ -32,12 +32,13 @@ import RnExpr		( rnMatch, rnGRHSsAndBinds, rnPat, checkPrecMatch )
 import CmdLineOpts	( opt_SigsRequired )
 import Digraph		( stronglyConnComp )
 import ErrUtils		( addErrLoc, addShortErrLocLine )
-import Name		( RdrName )
+import Name		( getLocalName, RdrName )
 import Maybes		( catMaybes )
+--import PprStyle--ToDo:rm
 import Pretty
 import UniqSet		( emptyUniqSet, unitUniqSet, mkUniqSet,
 			  unionUniqSets, unionManyUniqSets,
-			  elementOfUniqSet, uniqSetToList, UniqSet(..) )
+			  elementOfUniqSet, uniqSetToList, SYN_IE(UniqSet) )
 import Util		( thenCmp, isIn, removeDups, panic, panic#, assertPanic )
 \end{code}
 
@@ -261,7 +262,7 @@ rnMonoBinds mbinds siglist
 
 	 -- Do the SCC analysis
     let vertices = mkVertices mbinds_info
-	edges	= mkEdges vertices mbinds_info
+	edges	= mkEdges     mbinds_info
 
 	scc_result = stronglyConnComp (==) edges vertices
 
@@ -316,9 +317,9 @@ flattenMonoBinds :: Int				-- Next free vertex tag
 
 flattenMonoBinds uniq sigs EmptyMonoBinds = returnRn (uniq, [])
 
-flattenMonoBinds uniq sigs (AndMonoBinds mB1 mB2)
-  = flattenMonoBinds uniq sigs mB1	`thenRn` \ (uniq1, flat1) ->
-    flattenMonoBinds uniq1 sigs mB2	`thenRn` \ (uniq2, flat2) ->
+flattenMonoBinds uniq sigs (AndMonoBinds bs1 bs2)
+  = flattenMonoBinds uniq  sigs bs1	`thenRn` \ (uniq1, flat1) ->
+    flattenMonoBinds uniq1 sigs bs2	`thenRn` \ (uniq2, flat2) ->
     returnRn (uniq2, flat1 ++ flat2)
 
 flattenMonoBinds uniq sigs (PatMonoBind pat grhss_and_binds locn)
@@ -471,27 +472,28 @@ type FlatMonoBindsInfo
     ]
 
 mkVertices :: FlatMonoBindsInfo -> [VertexTag]
-mkVertices info = [ vertex | (vertex,_,_,_,_) <- info]
+mkEdges    :: FlatMonoBindsInfo -> [Edge]
 
-mkEdges :: [VertexTag] -> FlatMonoBindsInfo -> [Edge]
+mkVertices info = [ vertex | (vertex,_,_,_,_) <- info]
 
-mkEdges vertices flat_info
+mkEdges flat_info
  -- An edge (v,v') indicates that v depends on v'
- = [ (source_vertex, target_vertex)
-   | (source_vertex, _, used_names, _, _) <- flat_info,
-     target_name   <- uniqSetToList used_names,
-     target_vertex <- vertices_defining target_name flat_info
-   ]
-   where
-   -- If each name only has one binding in this group, then
-   -- vertices_defining will always return the empty list, or a
-   -- singleton.  The case when there is more than one binding (an
-   -- error) needs more thought.
-
-   vertices_defining name flat_info2
-    = [ vertex |  (vertex, names_defined, _, _, _) <- flat_info2,
-		name `elementOfUniqSet` names_defined
-      ]
+  = -- pprTrace "mkEdges:" (ppAboves [ppAboves[ppInt v, ppCat [ppr PprDebug d|d <- uniqSetToList defd], ppCat [ppr PprDebug u|u <- uniqSetToList used]] | (v,defd,used,_,_) <- flat_info]) $
+    [ (source_vertex, target_vertex)
+    | (source_vertex, _, used_names, _, _) <- flat_info,
+      target_name   <- uniqSetToList used_names,
+      target_vertex <- vertices_defining target_name flat_info
+    ]
+    where
+    -- If each name only has one binding in this group, then
+    -- vertices_defining will always return the empty list, or a
+    -- singleton.  The case when there is more than one binding (an
+    -- error) needs more thought.
+
+    vertices_defining name flat_info2
+     = [ vertex |  (vertex, names_defined, _, _, _) <- flat_info2,
+		 name `elementOfUniqSet` names_defined
+       ]
 \end{code}
 
 
@@ -522,7 +524,7 @@ rnBindSigs is_toplev binder_occnames sigs
 	 -- Discard unbound ones we've already complained about, so we
 	 -- complain about duplicate ones.
 
-	(goodies, dups) = removeDups compare (filter not_unbound sigs')
+	(goodies, dups) = removeDups compare (filter (\ x -> not_unbound x && not_main x) sigs')
     in
     mapRn (addErrRn . dupSigDeclErr) dups `thenRn_`
 
@@ -596,7 +598,7 @@ rnBindSigs is_toplev binder_occnames sigs
 	   lookupValue v	`thenRn` \ new_v ->
 	   returnRn (Just (MagicUnfoldingSig new_v str src_loc))
 
-    not_unbound :: RenamedSig -> Bool
+    not_unbound, not_main :: RenamedSig -> Bool
 
     not_unbound (Sig n _ _ _)		  = not (isRnUnbound n)
     not_unbound (SpecSig n _ _ _)	  = not (isRnUnbound n)
@@ -604,6 +606,10 @@ rnBindSigs is_toplev binder_occnames sigs
     not_unbound (DeforestSig n _)	  = not (isRnUnbound n)
     not_unbound (MagicUnfoldingSig n _ _) = not (isRnUnbound n)
 
+    not_main (Sig n _ _ _)  = let str = getLocalName n in
+			      not (str == SLIT("main") || str == SLIT("mainPrimIO"))
+    not_main _		    = True
+
     -------------------------------------
     sig_free :: [RdrNameSig] -> RdrName -> Maybe RdrName
 	-- Return "Just x" if "x" has no type signature in