Improve the treatment of 'seq' (Trac #2273)

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

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index a9c4e02..637d4c5 100644 (file)
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -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,26 +1134,27 @@ 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}
 
 \begin{code}
+------------------------------------------------
 -- unsafeCoerce# :: forall a b. a -> b
 unsafeCoerceId
   = pcMiscPrelId unsafeCoerceName ty info
@@ -1167,17 +1168,23 @@ unsafeCoerceId
     rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $
           Cast (Var x) (mkUnsafeCoercion openAlphaTy openBetaTy)
 
+------------------------------------------------
+nullAddrId :: Id
 -- nullAddr# :: Addr#
 -- The reason is is here is because we don't provide 
 -- a way to write this literal in Haskell.
-nullAddrId 
-  = pcMiscPrelId nullAddrName addrPrimTy info
+nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info
   where
     info = noCafIdInfo `setUnfoldingInfo` 
            mkCompulsoryUnfolding (Lit nullAddrLit)
 
-seqId
-  = pcMiscPrelId seqName ty info
+------------------------------------------------
+seqId :: Id
+-- 'seq' is very special.  See notes with
+--     See DsUtils.lhs Note [Desugaring seq (1)] and
+--                     Note [Desugaring seq (2)] and
+-- Fixity is set in LoadIface.ghcPrimIface
+seqId = pcMiscPrelId seqName ty info
   where
     info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
            
@@ -1187,6 +1194,8 @@ seqId
     [x,y] = mkTemplateLocals [alphaTy, openBetaTy]
     rhs = mkLams [alphaTyVar,openBetaTyVar,x,y] (Case (Var x) x openBetaTy [(DEFAULT, [], Var y)])
 
+------------------------------------------------
+lazyId :: Id
 -- lazy :: forall a?. a? -> a?   (i.e. works for unboxed types too)
 -- Used to lazify pseq:         pseq a b = a `seq` lazy b
 -- 
@@ -1198,8 +1207,7 @@ seqId
 --      (see WorkWrap.wwExpr)   
 -- We could use inline phases to do this, but that would be vulnerable to changes in 
 -- phase numbering....we must inline precisely after strictness analysis.
-lazyId
-  = pcMiscPrelId lazyIdName ty info
+lazyId = pcMiscPrelId lazyIdName ty info
   where
     info = noCafIdInfo
     ty  = mkForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy)
@@ -1231,7 +1239,7 @@ realWorldPrimId -- :: State# RealWorld
 
 voidArgId :: Id
 voidArgId       -- :: State# RealWorld
-  = mkSysLocal FSLIT("void") voidArgIdKey realWorldStatePrimTy
+  = mkSysLocal (fsLit "void") voidArgIdKey realWorldStatePrimTy
 \end{code}
 
 
@@ -1314,10 +1322,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 +1339,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}