X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDesugar.lhs;h=4ca1ddd70c4fcc0dc590d892985bcaa51230ed47;hb=fd1375dd261725eb00969a3017b924369c09835c;hp=99be1b0a465b8d49cd711dd5e650da383352cb71;hpb=eb2bf7ad9f967861da2e19ff71a80428c7c2df28;p=ghc-hetmet.git

diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index 99be1b0..4ca1ddd 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
@@ -45,7 +46,6 @@ import Util
 import Coverage
 import IOEnv
 import Data.IORef
-
 \end{code}
 
 %************************************************************************
@@ -78,36 +78,35 @@ deSugar hsc_env
 			    tcg_rules        = rules,
 		    	    tcg_insts        = insts,
 		    	    tcg_fam_insts    = fam_insts })
-  = do	{ showPass dflags "Desugar"
+
+  = do	{ let dflags = hsc_dflags hsc_env
+        ; showPass dflags "Desugar"
 
 	-- Desugar the program
         ; let export_set = availsToNameSet exports
 	; let auto_scc = mkAutoScc mod export_set
-        ; let noDbgSites = []
-	; mb_res <- case ghcMode dflags of
-	             JustTypecheck -> return (Just ([], [], NoStubs, noHpcInfo, noDbgSites))
-                     _        -> do (binds_cvr,ds_hpc_info) 
-					      <- if opt_Hpc
+        ; let target = hscTarget dflags
+	; mb_res <- case target of
+	             HscNothing -> return (Just ([], [], NoStubs, noHpcInfo, emptyModBreaks))
+                     _        -> do (binds_cvr,ds_hpc_info, modBreaks) 
+					      <- if opt_Hpc || target == HscInterpreted
                                                  then addCoverageTicksToBinds dflags mod mod_loc binds
-                                                 else return (binds, noHpcInfo)
+                                                 else return (binds, noHpcInfo, emptyModBreaks)
                                     initDs hsc_env mod rdr_env type_env $ do
 		                        { core_prs <- dsTopLHsBinds auto_scc binds_cvr
 		                        ; (ds_fords, foreign_prs) <- dsForeigns fords
 		                        ; let all_prs = foreign_prs ++ core_prs
 		                              local_bndrs = mkVarSet (map fst all_prs)
 		                        ; ds_rules <- mappM (dsRule mod local_bndrs) rules
-		                        ; return (all_prs, catMaybes ds_rules, ds_fords, ds_hpc_info)
-                                        ; dbgSites_var <- getBkptSitesDs
-                                        ; dbgSites <- ioToIOEnv$ readIORef dbgSites_var
-		                        ; return (all_prs, catMaybes ds_rules, ds_fords, ds_hpc_info, dbgSites)
+		                        ; return (all_prs, catMaybes ds_rules, ds_fords, ds_hpc_info, modBreaks)
 		                        }
 	; case mb_res of {
 	   Nothing -> return Nothing ;
-	   Just (all_prs, ds_rules, ds_fords,ds_hpc_info, dbgSites) -> do
+	   Just (all_prs, ds_rules, ds_fords,ds_hpc_info, modBreaks) -> do
 
 	{ 	-- Add export flags to bindings
 	  keep_alive <- readIORef keep_var
-	; let final_prs = addExportFlags ghci_mode export_set
+	; let final_prs = addExportFlags target export_set
                                  keep_alive all_prs ds_rules
 	      ds_binds  = [Rec final_prs]
 	-- Notice that we put the whole lot in a big Rec, even the foreign binds
@@ -174,14 +173,10 @@ deSugar hsc_env
 		mg_binds     	= ds_binds,
 		mg_foreign   	= ds_fords,
 		mg_hpc_info  	= ds_hpc_info,
-                mg_dbg_sites 	= dbgSites }
+                mg_modBreaks    = modBreaks }
         ; return (Just mod_guts)
 	}}}
 
-  where
-    dflags    = hsc_dflags hsc_env
-    ghci_mode = ghcMode (hsc_dflags hsc_env)
-
 mkAutoScc :: Module -> NameSet -> AutoScc
 mkAutoScc mod exports
   | not opt_SccProfilingOn 	-- No profiling
@@ -233,7 +228,7 @@ deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
 -- it's just because the type checker is rather busy already and
 -- I didn't want to pass in yet another mapping.
 
-addExportFlags ghci_mode exports keep_alive prs rules
+addExportFlags target exports keep_alive prs rules
   = [(add_export bndr, rhs) | (bndr,rhs) <- prs]
   where
     add_export bndr
@@ -262,7 +257,7 @@ addExportFlags ghci_mode exports keep_alive prs rules
 	-- isExternalName separates the user-defined top-level names from those
 	-- introduced by the type checker.
     is_exported :: Name -> Bool
-    is_exported | ghci_mode == Interactive = isExternalName
+    is_exported | target == HscInterpreted = isExternalName
 		| otherwise 		   = (`elemNameSet` exports)
 
 ppr_ds_rules [] = empty
@@ -283,23 +278,24 @@ 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
-	{ let local_rule = nameIsLocalOrFrom mod fn_name
-		-- NB we can't use isLocalId in the orphan test, 
-		-- because isLocalId isn't true of class methods
+	{ 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, 
+		-- because they don't show up in the bindings until just before code gen
 	      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)