Make the arity and strictness agree, for wired-in bottoming Ids

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

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 68bafde..3e63c31 100644 (file)
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -50,9 +50,9 @@ import Rules
 import TysPrim
 import TysWiredIn
 import PrelRules
+import Unify
 import Type
 import TypeRep
-import TcGadt
 import Coercion
 import TcType
 import CoreUtils
@@ -594,8 +594,8 @@ mkRecordSelId tycon field_label
         -- 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:
-        -- n_dict tys depends on the_alts, which depens on arg_ids, which depends
-        -- on arity, which depends on n_dict tys.  Sigh!  Mega sigh!
+        -- n_dict tys depends on the_alts, which depens on arg_ids, which 
+        -- depends on arity, which depends on n_dict tys.  Sigh!  Mega sigh!
     stupid_dict_ids  = mkTemplateLocalsNum 1 stupid_dict_tys
     max_stupid_dicts = length (tyConStupidTheta tycon)
     field_dict_base  = max_stupid_dicts + 1
@@ -638,13 +638,15 @@ mkRecordSelId tycon field_label
         --      foo :: forall a. T -> a -> a
         --      foo = /\a. \t:T. case t of { MkT f -> f a }
 
-    mk_alt data_con 
-      =   ASSERT2( data_ty `tcEqType` field_ty, ppr data_con $$ ppr data_ty $$ ppr field_ty )
+    mk_alt data_con
+      =   ASSERT2( data_ty `tcEqType` field_ty, 
+                   ppr data_con $$ ppr data_ty $$ ppr field_ty )
           mkReboxingAlt rebox_uniqs data_con (ex_tvs ++ co_tvs ++ arg_vs) rhs
       where
            -- get pattern binders with types appropriately instantiated
         arg_uniqs = map mkBuiltinUnique [arg_base..]
-        (ex_tvs, co_tvs, arg_vs) = dataConOrigInstPat arg_uniqs data_con scrut_ty_args
+        (ex_tvs, co_tvs, arg_vs) = dataConOrigInstPat arg_uniqs data_con 
+                                                      scrut_ty_args
 
         rebox_base  = arg_base + length ex_tvs + length co_tvs + length arg_vs
         rebox_uniqs = map mkBuiltinUnique [rebox_base..]
@@ -656,17 +658,18 @@ 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
-        the_arg_id_ty = idType the_arg_id
-        (rhs, data_ty) = case refineType refinement the_arg_id_ty of
-                          Just (co, data_ty) -> (Cast (Var the_arg_id) co, data_ty)
-                          Nothing            -> (Var the_arg_id, the_arg_id_ty)
+        reft           = matchRefine co_tvs
+        the_arg_id_ty  = idType the_arg_id
+        (rhs, data_ty) = 
+          case refineType reft the_arg_id_ty of
+            Just (co, data_ty) -> (Cast (Var the_arg_id) co, data_ty)
+            Nothing            -> (Var the_arg_id, the_arg_id_ty)
 
         field_vs    = filter (not . isPredTy . idType) arg_vs 
-        the_arg_id  = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` field_vs) field_label
+        the_arg_id  = assoc "mkRecordSelId:mk_alt" 
+                            (field_lbls `zip` field_vs) field_label
         field_lbls  = dataConFieldLabels data_con
 
     error_expr = mkRuntimeErrorApp rEC_SEL_ERROR_ID field_ty full_msg
@@ -828,8 +831,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))
@@ -841,8 +847,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
@@ -1307,10 +1314,14 @@ pcMiscPrelId name ty info
     -- will be in "the right place" to be in scope.
 
 pc_bottoming_Id :: Name -> Type -> Id
+-- Function of arity 1, which diverges after being given one argument
 pc_bottoming_Id name ty
  = pcMiscPrelId name ty bottoming_info
  where
     bottoming_info = vanillaIdInfo `setAllStrictnessInfo` Just strict_sig
+                                  `setArityInfo`         1
+                       -- Make arity and strictness agree
+
         -- Do *not* mark them as NoCafRefs, because they can indeed have
         -- CAF refs.  For example, pAT_ERROR_ID calls GHC.Err.untangle,
         -- which has some CAFs
@@ -1320,7 +1331,7 @@ pc_bottoming_Id name ty
         -- any pc_bottoming_Id will itself have CafRefs, which bloats
         -- SRTs.
 
-    strict_sig     = mkStrictSig (mkTopDmdType [evalDmd] BotRes)
+    strict_sig = mkStrictSig (mkTopDmdType [evalDmd] BotRes)
         -- These "bottom" out, no matter what their arguments
 \end{code}