Add ASSERTs to all calls of nameModule

[ghc-hetmet.git] / compiler / basicTypes / MkId.lhs

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 2262bbc..f9eae93 100644 (file)
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -334,7 +334,7 @@ mkDataConIds wrap_name wkr_name data_con
         --      ...(let w = C x in ...(w p q)...)...
         -- we want to see that w is strict in its two arguments
 
-    wrap_unf = mkTopUnfolding $ Note InlineMe $
+    wrap_unf = mkImplicitUnfolding $ Note InlineMe $
               mkLams wrap_tvs $ 
               mkLams eq_args $
               mkLams dict_args $ mkLams id_args $
@@ -602,9 +602,11 @@ mkRecordSelId tycon field_label
     info = noCafIdInfo
            `setCafInfo`           caf_info
            `setArityInfo`         arity
-           `setUnfoldingInfo`     mkTopUnfolding rhs_w_str
+           `setUnfoldingInfo`     unfolding
            `setAllStrictnessInfo` Just strict_sig
 
+    unfolding = mkImplicitUnfolding rhs_w_str
+
         -- Allocate Ids.  We do it a funny way round because field_dict_tys is
         -- almost always empty.  Also note that we use max_dict_tys
         -- rather than n_dict_tys, because the latter gives an infinite loop:
@@ -862,7 +864,7 @@ mkDictSelId no_unf name clas
                 `setArityInfo`          1
                 `setAllStrictnessInfo`  Just strict_sig
                 `setUnfoldingInfo`      (if no_unf then noUnfolding
-                                                  else mkTopUnfolding rhs)
+                                                  else mkImplicitUnfolding rhs)
 
         -- We no longer use 'must-inline' on record selectors.  They'll
         -- inline like crazy if they scrutinise a constructor
@@ -1154,15 +1156,15 @@ realWorldName    = mkWiredInIdName gHC_PRIM (fsLit "realWorld#")    realWorldPri
 lazyIdName       = mkWiredInIdName gHC_BASE (fsLit "lazy")         lazyIdKey           lazyId
 
 errorName                = mkWiredInIdName gHC_ERR (fsLit "error")            errorIdKey eRROR_ID
-recSelErrorName          = mkWiredInIdName cONTROL_EXCEPTION (fsLit "recSelError")     recSelErrorIdKey rEC_SEL_ERROR_ID
-runtimeErrorName         = mkWiredInIdName cONTROL_EXCEPTION (fsLit "runtimeError")    runtimeErrorIdKey rUNTIME_ERROR_ID
-irrefutPatErrorName      = mkWiredInIdName cONTROL_EXCEPTION (fsLit "irrefutPatError") irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID
-recConErrorName          = mkWiredInIdName cONTROL_EXCEPTION (fsLit "recConError")     recConErrorIdKey rEC_CON_ERROR_ID
-patErrorName             = mkWiredInIdName cONTROL_EXCEPTION (fsLit "patError")         patErrorIdKey pAT_ERROR_ID
-noMethodBindingErrorName = mkWiredInIdName cONTROL_EXCEPTION (fsLit "noMethodBindingError")
+recSelErrorName          = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "recSelError")     recSelErrorIdKey rEC_SEL_ERROR_ID
+runtimeErrorName         = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "runtimeError")    runtimeErrorIdKey rUNTIME_ERROR_ID
+irrefutPatErrorName      = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "irrefutPatError") irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID
+recConErrorName          = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "recConError")     recConErrorIdKey rEC_CON_ERROR_ID
+patErrorName             = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "patError")         patErrorIdKey pAT_ERROR_ID
+noMethodBindingErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "noMethodBindingError")
                                            noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID
 nonExhaustiveGuardsErrorName 
-  = mkWiredInIdName gHC_ERR (fsLit "nonExhaustiveGuardsError") 
+  = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "nonExhaustiveGuardsError") 
                     nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID
 \end{code}