Use ":Co", not "Co" to prefix coercion TyCon names

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

diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index c2ee0a5..f49a84c 100644 (file)
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -9,7 +9,9 @@ module Desugar ( deSugar, deSugarExpr ) where
 #include "HsVersions.h"
 
 import DynFlags                ( DynFlag(..), DynFlags(..), dopt, GhcMode(..) )
-import StaticFlags     ( opt_SccProfilingOn )
+import StaticFlags     ( opt_SccProfilingOn,
+                         opt_AutoSccsOnAllToplevs,
+                         opt_AutoSccsOnExportedToplevs )
 import DriverPhases    ( isHsBoot )
 import HscTypes                ( ModGuts(..), HscEnv(..), 
                          Dependencies(..), ForeignStubs(..), TypeEnv, IsBootInterface )
@@ -71,10 +73,13 @@ deSugar hsc_env
                            tcg_binds     = binds,
                            tcg_fords     = fords,
                            tcg_rules     = rules,
-                           tcg_insts     = insts })
+                           tcg_insts     = insts,
+                           tcg_fam_insts = fam_insts })
   = do { showPass dflags "Desugar"
 
        -- Desugar the program
+       ; let auto_scc = mkAutoScc mod exports
+
        ; mb_res <- case ghcMode dflags of
                     JustTypecheck -> return (Just ([], [], NoStubs))
                     _             -> initDs hsc_env mod rdr_env type_env $ do
@@ -92,7 +97,7 @@ deSugar hsc_env
        {       -- Add export flags to bindings
          keep_alive <- readIORef keep_var
        ; let final_prs = addExportFlags ghci_mode exports keep_alive 
-                                        all_prs ds_rules
+                                all_prs ds_rules
              ds_binds  = [Rec final_prs]
        -- Notice that we put the whole lot in a big Rec, even the foreign binds
        -- When compiling PrelFloat, which defines data Float = F# Float#
@@ -140,20 +145,21 @@ deSugar hsc_env
                -- sort to get into canonical order
 
             mod_guts = ModGuts {       
-               mg_module   = mod,
-               mg_boot     = isHsBoot hsc_src,
-               mg_exports  = exports,
-               mg_deps     = deps,
-               mg_usages   = usages,
-               mg_dir_imps = [m | (m,_,_) <- moduleEnvElts dir_imp_mods],
-               mg_rdr_env  = rdr_env,
-               mg_fix_env  = fix_env,
-               mg_deprecs  = deprecs,
-               mg_types    = type_env,
-               mg_insts    = insts,
-               mg_rules    = ds_rules,
-               mg_binds    = ds_binds,
-               mg_foreign  = ds_fords }
+               mg_module    = mod,
+               mg_boot      = isHsBoot hsc_src,
+               mg_exports   = exports,
+               mg_deps      = deps,
+               mg_usages    = usages,
+               mg_dir_imps  = [m | (m,_,_) <- moduleEnvElts dir_imp_mods],
+               mg_rdr_env   = rdr_env,
+               mg_fix_env   = fix_env,
+               mg_deprecs   = deprecs,
+               mg_types     = type_env,
+               mg_insts     = insts,
+               mg_fam_insts = fam_insts,
+               mg_rules     = ds_rules,
+               mg_binds     = ds_binds,
+               mg_foreign   = ds_fords }
        
         ; return (Just mod_guts)
        }}}
@@ -161,8 +167,18 @@ deSugar hsc_env
   where
     dflags    = hsc_dflags hsc_env
     ghci_mode = ghcMode (hsc_dflags hsc_env)
-    auto_scc | opt_SccProfilingOn = TopLevel
-            | otherwise          = NoSccs
+
+mkAutoScc :: Module -> NameSet -> AutoScc
+mkAutoScc mod exports
+  | not opt_SccProfilingOn     -- No profiling
+  = NoSccs             
+  | opt_AutoSccsOnAllToplevs   -- Add auto-scc on all top-level things
+  = AddSccs mod (\id -> True)
+  | opt_AutoSccsOnExportedToplevs      -- Only on exported things
+  = AddSccs mod (\id -> idName id `elemNameSet` exports)
+  | otherwise
+  = NoSccs
+
 
 deSugarExpr :: HscEnv
            -> Module -> GlobalRdrEnv -> TypeEnv