X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDesugar.lhs;h=521d1ad401f9ed62086a520d158b1a0c65d27256;hp=ab9f8c7c26afe437a282d2c1f25ceac6ee0dfbda;hb=f96194794bf099020706c3816d1a5678b40addbb;hpb=3b2cd7b311da1e7056ef66b42efc2571add5a8aa

diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index ab9f8c7..521d1ad 100644
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -17,7 +17,6 @@ import MkIface
 import Id
 import Name
 import CoreSyn
-import OccurAnal
 import PprCore
 import DsMonad
 import DsExpr
@@ -49,6 +48,7 @@ import Data.IORef
 %************************************************************************
 
 \begin{code}
+-- | Main entry point to the desugarer.
 deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
 -- Can modify PCS by faulting in more declarations
 
@@ -64,7 +64,8 @@ deSugar hsc_env
 		    	    tcg_fix_env      = fix_env,
 		    	    tcg_inst_env     = inst_env,
 		    	    tcg_fam_inst_env = fam_inst_env,
-	    	    	    tcg_warns      = warns,
+	    	    	    tcg_warns        = warns,
+	    	    	    tcg_anns         = anns,
 			    tcg_binds        = binds,
 			    tcg_fords        = fords,
 			    tcg_rules        = rules,
@@ -77,7 +78,7 @@ deSugar hsc_env
 
 	-- Desugar the program
         ; let export_set = availsToNameSet exports
-	; let auto_scc = mkAutoScc mod export_set
+	; let auto_scc = mkAutoScc dflags mod export_set
         ; let target = hscTarget dflags
         ; let hpcInfo = emptyHpcInfo other_hpc_info
 	; (msgs, mb_res)
@@ -134,6 +135,7 @@ deSugar hsc_env
 	        mg_rdr_env   	= rdr_env,
 		mg_fix_env   	= fix_env,
 		mg_warns   	= warns,
+		mg_anns      	= anns,
 		mg_types     	= type_env,
 		mg_insts     	= insts,
 		mg_fam_insts 	= fam_insts,
@@ -149,16 +151,18 @@ deSugar hsc_env
         ; return (msgs, Just mod_guts)
 	}}}
 
-mkAutoScc :: Module -> NameSet -> AutoScc
-mkAutoScc mod exports
+mkAutoScc :: DynFlags -> Module -> NameSet -> AutoScc
+mkAutoScc dflags mod exports
   | not opt_SccProfilingOn 	-- No profiling
   = NoSccs		
-  | opt_AutoSccsOnAllToplevs 	-- Add auto-scc on all top-level things
+    -- Add auto-scc on all top-level things
+  | dopt Opt_AutoSccsOnAllToplevs dflags
   = AddSccs mod (\id -> not $ isDerivedOccName $ getOccName id)
     -- See #1641.  This is pretty yucky, but I can't see a better way
     -- to identify compiler-generated Ids, and at least this should
     -- catch them all.
-  | opt_AutoSccsOnExportedToplevs	-- Only on exported things
+    -- Only on exported things
+  | dopt Opt_AutoSccsOnExportedToplevs dflags
   = AddSccs mod (\id -> idName id `elemNameSet` exports)
   | otherwise
   = NoSccs
@@ -239,7 +243,7 @@ addExportFlags target exports keep_alive prs rules
 ppr_ds_rules :: [CoreRule] -> SDoc
 ppr_ds_rules [] = empty
 ppr_ds_rules rules
-  = text "" $$ text "-------------- DESUGARED RULES -----------------" $$
+  = blankLine $$ text "-------------- DESUGARED RULES -----------------" $$
     pprRules rules
 \end{code}
 
@@ -255,16 +259,16 @@ ppr_ds_rules rules
 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
 dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
   = putSrcSpanDs loc $ 
-    do	{ let bndrs = [var | RuleBndr (L _ var) <- vars]
+    do	{ let bndrs' = [var | RuleBndr (L _ var) <- vars]
 	; lhs'  <- dsLExpr lhs
 	; rhs'  <- dsLExpr rhs
 
-	; case decomposeRuleLhs (occurAnalyseExpr lhs') of {
-		Nothing -> do { warnDs msg; return Nothing } ;
-		Just (fn_id, args) -> do
-	
 	-- Substitute the dict bindings eagerly,
 	-- and take the body apart into a (f args) form
+	; case decomposeRuleLhs (mkLams bndrs' lhs') of {
+		Nothing -> do { warnDs msg; return Nothing } ;
+		Just (bndrs, fn_id, args) -> do
+	
 	{ let local_rule = isLocalId fn_id
 		-- NB: isLocalId is False of implicit Ids.  This is good becuase
 		-- we don't want to attach rules to the bindings of implicit Ids,