Re-working of the breakpoint support

[ghc-hetmet.git] / compiler / deSugar / Desugar.lhs

diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index b4ff273..4b60768 100644 (file)
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -45,7 +45,6 @@ import Util
 import Coverage
 import IOEnv
 import Data.IORef
-
 \end{code}
 
 %************************************************************************
@@ -78,36 +77,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 +172,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 +227,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 +256,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
@@ -293,24 +287,16 @@ dsRule mod in_scope (L loc (HsRule name act vars lhs tv_lhs rhs fv_rhs))
        
        -- 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
-             lhs_names = fn_name : nameSetToList (exprsFreeNames args)
-               -- No need to delete bndrs, because
-               -- exprsFreeNames finds only External names
-
-               -- A rule is an orphan only if none of the variables
-               -- mentioned on its left-hand side are locally defined
-             orph = case filter (nameIsLocalOrFrom mod) lhs_names of
-                       (n:ns) -> Just (nameOccName n)
-                       []     -> Nothing
 
              rule = Rule { ru_name = name, ru_fn = fn_name, ru_act = act,
                            ru_bndrs = bndrs', ru_args = args, ru_rhs = rhs', 
                            ru_rough = roughTopNames args, 
-                           ru_local = local_rule, ru_orph = orph }
+                           ru_local = local_rule }
        ; return (Just rule)
        } } }
   where