X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FMkId.lhs;h=9f9b3fe423b5a522557680857e2295cf721c7c52;hb=7df9b88b9e0565f438f16d8005526ffda80a1dbe;hp=4f302912ef74b7bc303e29897b3843ec049c561d;hpb=bf1bf9fb07f1607aa66e7490b2df1ac1b62dd2d0;p=ghc-hetmet.git

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 4f30291..9f9b3fe 100644
--- 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
@@ -355,7 +355,7 @@ mkDataConIds wrap_name wkr_name data_con
 
     mkCoVarLocals i []     = ([],i)
     mkCoVarLocals i (x:xs) = let (ys,j) = mkCoVarLocals (i+1) xs
-                                 y      = mkCoVar (mkSysTvName (mkBuiltinUnique i) FSLIT("dc_co")) x
+                                 y      = mkCoVar (mkSysTvName (mkBuiltinUnique i) (fsLit "dc_co")) x
                              in (y:ys,j)
 
     mk_case 
@@ -729,7 +729,7 @@ reboxProduct us ty
  
         us' = dropList con_arg_tys us
 
-        arg_ids  = zipWith (mkSysLocal FSLIT("rb")) us con_arg_tys
+        arg_ids  = zipWith (mkSysLocal (fsLit "rb")) us con_arg_tys
 
         bind_rhs = mkProductBox arg_ids ty
 
@@ -877,7 +877,7 @@ mkDictSelId no_unf name clas
 
     mkCoVarLocals i []     = ([],i)
     mkCoVarLocals i (x:xs) = let (ys,j) = mkCoVarLocals (i+1) xs
-                                 y      = mkCoVar (mkSysTvName (mkBuiltinUnique i) FSLIT("dc_co")) x
+                                 y      = mkCoVar (mkSysTvName (mkBuiltinUnique i) (fsLit "dc_co")) x
                              in (y:ys,j)
 
     rhs = mkLams tyvars  (Lam dict_id   rhs_body)
@@ -1134,22 +1134,22 @@ another gun with which to shoot yourself in the foot.
 mkWiredInIdName mod fs uniq id
  = mkWiredInName mod (mkOccNameFS varName fs) uniq (AnId id) UserSyntax
 
-unsafeCoerceName = mkWiredInIdName gHC_PRIM FSLIT("unsafeCoerce#") unsafeCoerceIdKey  unsafeCoerceId
-nullAddrName     = mkWiredInIdName gHC_PRIM FSLIT("nullAddr#")     nullAddrIdKey      nullAddrId
-seqName          = mkWiredInIdName gHC_PRIM FSLIT("seq")           seqIdKey           seqId
-realWorldName    = mkWiredInIdName gHC_PRIM FSLIT("realWorld#")    realWorldPrimIdKey realWorldPrimId
-lazyIdName       = mkWiredInIdName gHC_BASE FSLIT("lazy")         lazyIdKey           lazyId
-
-errorName                = mkWiredInIdName gHC_ERR FSLIT("error")            errorIdKey eRROR_ID
-recSelErrorName          = mkWiredInIdName gHC_ERR FSLIT("recSelError")     recSelErrorIdKey rEC_SEL_ERROR_ID
-runtimeErrorName         = mkWiredInIdName gHC_ERR FSLIT("runtimeError")    runtimeErrorIdKey rUNTIME_ERROR_ID
-irrefutPatErrorName      = mkWiredInIdName gHC_ERR FSLIT("irrefutPatError") irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID
-recConErrorName          = mkWiredInIdName gHC_ERR FSLIT("recConError")     recConErrorIdKey rEC_CON_ERROR_ID
-patErrorName             = mkWiredInIdName gHC_ERR FSLIT("patError")         patErrorIdKey pAT_ERROR_ID
-noMethodBindingErrorName = mkWiredInIdName gHC_ERR FSLIT("noMethodBindingError")
+unsafeCoerceName = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey  unsafeCoerceId
+nullAddrName     = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#")     nullAddrIdKey      nullAddrId
+seqName          = mkWiredInIdName gHC_PRIM (fsLit "seq")           seqIdKey           seqId
+realWorldName    = mkWiredInIdName gHC_PRIM (fsLit "realWorld#")    realWorldPrimIdKey realWorldPrimId
+lazyIdName       = mkWiredInIdName gHC_BASE (fsLit "lazy")         lazyIdKey           lazyId
+
+errorName                = mkWiredInIdName gHC_ERR (fsLit "error")            errorIdKey eRROR_ID
+recSelErrorName          = mkWiredInIdName gHC_ERR (fsLit "recSelError")     recSelErrorIdKey rEC_SEL_ERROR_ID
+runtimeErrorName         = mkWiredInIdName gHC_ERR (fsLit "runtimeError")    runtimeErrorIdKey rUNTIME_ERROR_ID
+irrefutPatErrorName      = mkWiredInIdName gHC_ERR (fsLit "irrefutPatError") irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID
+recConErrorName          = mkWiredInIdName gHC_ERR (fsLit "recConError")     recConErrorIdKey rEC_CON_ERROR_ID
+patErrorName             = mkWiredInIdName gHC_ERR (fsLit "patError")         patErrorIdKey pAT_ERROR_ID
+noMethodBindingErrorName = mkWiredInIdName gHC_ERR (fsLit "noMethodBindingError")
                                            noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID
 nonExhaustiveGuardsErrorName 
-  = mkWiredInIdName gHC_ERR FSLIT("nonExhaustiveGuardsError") 
+  = mkWiredInIdName gHC_ERR (fsLit "nonExhaustiveGuardsError") 
                     nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID
 \end{code}
 
@@ -1231,7 +1231,7 @@ realWorldPrimId -- :: State# RealWorld
 
 voidArgId :: Id
 voidArgId       -- :: State# RealWorld
-  = mkSysLocal FSLIT("void") voidArgIdKey realWorldStatePrimTy
+  = mkSysLocal (fsLit "void") voidArgIdKey realWorldStatePrimTy
 \end{code}
 
 
@@ -1314,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
@@ -1327,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}