Convert some DEBUG uses to debugIsOn

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

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 3ea5091..7d472b1 100644 (file)
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -12,7 +12,7 @@ have a standard form, namely:
 * primitive operations
 
 \begin{code}
-{-# OPTIONS -w #-}
+{-# OPTIONS -fno-warn-missing-signatures #-}
 -- The above warning supression flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and fix
 -- any warnings in the module. See
@@ -656,7 +656,6 @@ mkRecordSelId tycon field_label
         --              T1 b' (c : [b]=[b']) (x:Maybe b') 
         --                      -> x `cast` Maybe (sym (right c))
 
-
                 -- Generate the refinement for b'=b, 
                 -- and apply to (Maybe b'), to get (Maybe b)
         Succeeded refinement = gadtRefine emptyRefinement ex_tvs co_tvs
@@ -799,6 +798,7 @@ mkReboxingAlt us con args rhs
       | otherwise
       = let (binds, args') = go args stricts us
         in  (binds, arg:args')
+    go (_ : _) [] _ = panic "mkReboxingAlt"
 \end{code}
 
 
@@ -827,8 +827,11 @@ at the outside.  When dealing with classes it's very convenient to
 recover the original type signature from the class op selector.
 
 \begin{code}
-mkDictSelId :: Name -> Class -> Id
-mkDictSelId name clas
+mkDictSelId :: Bool    -- True <=> don't include the unfolding
+                       -- Little point on imports without -O, because the
+                       -- dictionary itself won't be visible
+           -> Name -> Class -> Id
+mkDictSelId no_unf name clas
   = mkGlobalId (ClassOpId clas) name sel_ty info
   where
     sel_ty = mkForAllTys tyvars (mkFunTy (idType dict_id) (idType the_arg_id))
@@ -840,8 +843,9 @@ mkDictSelId name clas
 
     info = noCafIdInfo
                 `setArityInfo`          1
-                `setUnfoldingInfo`      mkTopUnfolding rhs
                 `setAllStrictnessInfo`  Just strict_sig
+                `setUnfoldingInfo`      (if no_unf then noUnfolding
+                                                  else mkTopUnfolding rhs)
 
         -- We no longer use 'must-inline' on record selectors.  They'll
         -- inline like crazy if they scrutinise a constructor
@@ -1221,6 +1225,7 @@ realWorldPrimId -- :: State# RealWorld
         -- which in turn makes INLINE things applied to realWorld# likely
         -- to be inlined
 
+voidArgId :: Id
 voidArgId       -- :: State# RealWorld
   = mkSysLocal FSLIT("void") voidArgIdKey realWorldStatePrimTy
 \end{code}
@@ -1269,7 +1274,11 @@ nO_METHOD_BINDING_ERROR_ID      = mkRuntimeErrorId noMethodBindingErrorName
 nON_EXHAUSTIVE_GUARDS_ERROR_ID  = mkRuntimeErrorId nonExhaustiveGuardsErrorName
 
 -- The runtime error Ids take a UTF8-encoded string as argument
+
+mkRuntimeErrorId :: Name -> Id
 mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy
+
+runtimeErrorTy :: Type
 runtimeErrorTy        = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy)
 \end{code}
 
@@ -1300,6 +1309,7 @@ pcMiscPrelId name ty info
     -- being compiled, then it's just a matter of luck if the definition
     -- will be in "the right place" to be in scope.
 
+pc_bottoming_Id :: Name -> Type -> Id
 pc_bottoming_Id name ty
  = pcMiscPrelId name ty bottoming_info
  where