X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDesugar.lhs;h=9a4c2617b1f669c4af2b2862b6145eda7f4e9167;hp=4b60768fc3275468dc1b2e1ef3699c1c7bcc369b;hb=c1681a73fa4ca4cf8758264ae387ac09a9e900d8;hpb=cdce647711c0f46f5799b24de087622cb77e647f

diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index 4b60768..9a4c261 100644
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -19,6 +19,7 @@ import MkIface
 import Id
 import Name
 import CoreSyn
+import OccurAnal
 import PprCore
 import DsMonad
 import DsExpr
@@ -70,13 +71,15 @@ deSugar hsc_env
 			    tcg_keep	     = keep_var,
 		    	    tcg_rdr_env      = rdr_env,
 		    	    tcg_fix_env      = fix_env,
+		    	    tcg_inst_env     = inst_env,
 		    	    tcg_fam_inst_env = fam_inst_env,
 	    	    	    tcg_deprecs      = deprecs,
 			    tcg_binds        = binds,
 			    tcg_fords        = fords,
 			    tcg_rules        = rules,
 		    	    tcg_insts        = insts,
-		    	    tcg_fam_insts    = fam_insts })
+		    	    tcg_fam_insts    = fam_insts,
+			    tcg_hpc          = other_hpc_info })
 
   = do	{ let dflags = hsc_dflags hsc_env
         ; showPass dflags "Desugar"
@@ -85,12 +88,15 @@ deSugar hsc_env
         ; let export_set = availsToNameSet exports
 	; let auto_scc = mkAutoScc mod export_set
         ; let target = hscTarget dflags
+        ; let hpcInfo = emptyHpcInfo other_hpc_info
 	; mb_res <- case target of
-	             HscNothing -> return (Just ([], [], NoStubs, noHpcInfo, emptyModBreaks))
+	             HscNothing -> return (Just ([], [], NoStubs, hpcInfo, emptyModBreaks))
                      _        -> do (binds_cvr,ds_hpc_info, modBreaks) 
-					      <- if opt_Hpc || target == HscInterpreted
-                                                 then addCoverageTicksToBinds dflags mod mod_loc binds
-                                                 else return (binds, noHpcInfo, emptyModBreaks)
+					      <- if (opt_Hpc 
+							|| target == HscInterpreted)
+						     && (not (isHsBoot hsc_src))							
+                                                 then addCoverageTicksToBinds dflags mod mod_loc (typeEnvTyCons type_env) binds 
+                                                 else return (binds, hpcInfo, emptyModBreaks)
                                     initDs hsc_env mod rdr_env type_env $ do
 		                        { core_prs <- dsTopLHsBinds auto_scc binds_cvr
 		                        ; (ds_fords, foreign_prs) <- dsForeigns fords
@@ -167,12 +173,15 @@ deSugar hsc_env
 		mg_types     	= type_env,
 		mg_insts     	= insts,
 		mg_fam_insts 	= fam_insts,
+		mg_inst_env     = inst_env,
 		mg_fam_inst_env = fam_inst_env,
 	        mg_rules     	= ds_rules,
 		mg_binds     	= ds_binds,
 		mg_foreign   	= ds_fords,
 		mg_hpc_info  	= ds_hpc_info,
-                mg_modBreaks    = modBreaks }
+                mg_modBreaks    = modBreaks,
+                mg_vect_info    = noVectInfo
+              }
         ; return (Just mod_guts)
 	}}}
 
@@ -277,13 +286,13 @@ ppr_ds_rules rules
 dsRule :: Module -> IdSet -> LRuleDecl Id -> DsM (Maybe CoreRule)
 dsRule mod in_scope (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 bndrs lhs' of {
+	; case decomposeRuleLhs (occurAnalyseExpr lhs') of {
 		Nothing -> do { warnDs msg; return Nothing } ;
-		Just (bndrs', fn_id, args) -> do
+		Just (fn_id, args) -> do
 	
 	-- Substitute the dict bindings eagerly,
 	-- and take the body apart into a (f args) form
@@ -294,7 +303,7 @@ dsRule mod in_scope (L loc (HsRule name act vars lhs tv_lhs rhs fv_rhs))
 	      fn_name   = idName fn_id
 
 	      rule = Rule { ru_name = name, ru_fn = fn_name, ru_act = act,
-			    ru_bndrs = bndrs', ru_args = args, ru_rhs = rhs', 
+			    ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs', 
 			    ru_rough = roughTopNames args, 
 			    ru_local = local_rule }
 	; return (Just rule)