From 83a812bf720eb9d6662f32d2c25a283614d82c45 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Tue, 24 Jul 2001 15:57:27 +0000
Subject: [PATCH] [project @ 2001-07-24 15:57:27 by simonpj] Make absent-arg
 errors more descriptive

---
 ghc/compiler/basicTypes/MkId.lhs   |    9 ++++++---
 ghc/compiler/prelude/PrelNames.lhs |    1 +
 ghc/compiler/stranal/WwLib.lhs     |   15 ++++++++++++---
 3 files changed, 19 insertions(+), 6 deletions(-)

diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs
index b3c6be3..0d5bcec 100644
--- a/ghc/compiler/basicTypes/MkId.lhs
+++ b/ghc/compiler/basicTypes/MkId.lhs
@@ -23,7 +23,7 @@ module MkId (
 	-- And some particular Ids; see below for why they are wired in
 	wiredInIds,
 	unsafeCoerceId, realWorldPrimId,
-	eRROR_ID, rEC_SEL_ERROR_ID, pAT_ERROR_ID, rEC_CON_ERROR_ID,
+	eRROR_ID, eRROR_CSTRING_ID, rEC_SEL_ERROR_ID, pAT_ERROR_ID, rEC_CON_ERROR_ID,
 	rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID,
 	nO_METHOD_BINDING_ERROR_ID, aBSENT_ERROR_ID, pAR_ERROR_ID
     ) where
@@ -33,10 +33,9 @@ module MkId (
 
 import BasicTypes	( Arity, StrictnessMark(..), isMarkedUnboxed, isMarkedStrict )
 import TysPrim		( openAlphaTyVars, alphaTyVar, alphaTy, 
-			  intPrimTy, realWorldStatePrimTy
+			  intPrimTy, realWorldStatePrimTy, addrPrimTy
 			)
 import TysWiredIn	( charTy, mkListTy )
-import PrelNames	( pREL_ERR, pREL_GHC )
 import PrelRules	( primOpRule )
 import Rules		( addRule )
 import TcType		( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp,
@@ -112,6 +111,7 @@ wiredInIds
 
       aBSENT_ERROR_ID
     , eRROR_ID
+    , eRROR_CSTRING_ID
     , iRREFUT_PAT_ERROR_ID
     , nON_EXHAUSTIVE_GUARDS_ERROR_ID
     , nO_METHOD_BINDING_ERROR_ID
@@ -787,6 +787,9 @@ templates, but we don't ever expect to generate code for it.
 \begin{code}
 eRROR_ID
   = pc_bottoming_Id errorIdKey pREL_ERR SLIT("error") errorTy
+eRROR_CSTRING_ID
+  = pc_bottoming_Id errorCStringIdKey pREL_ERR SLIT("errorCString") 
+		    (mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy))
 pAT_ERROR_ID
   = generic_ERROR_ID patErrorIdKey SLIT("patError")
 rEC_SEL_ERROR_ID
diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs
index 7467fac..0f45777 100644
--- a/ghc/compiler/prelude/PrelNames.lhs
+++ b/ghc/compiler/prelude/PrelNames.lhs
@@ -809,6 +809,7 @@ irrefutPatErrorIdKey	      = mkPreludeMiscIdUnique 15
 eqStringIdKey		      = mkPreludeMiscIdUnique 16
 noMethodBindingErrorIdKey     = mkPreludeMiscIdUnique 17
 nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 18
+errorCStringIdKey	      = mkPreludeMiscIdUnique 19 
 parErrorIdKey		      = mkPreludeMiscIdUnique 20
 parIdKey		      = mkPreludeMiscIdUnique 21
 patErrorIdKey		      = mkPreludeMiscIdUnique 22
diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs
index f77a79d..54248a7 100644
--- a/ghc/compiler/stranal/WwLib.lhs
+++ b/ghc/compiler/stranal/WwLib.lhs
@@ -17,12 +17,13 @@ import Id		( Id, idType, mkSysLocal, idNewDemandInfo, setIdNewDemandInfo,
 import IdInfo		( vanillaIdInfo )
 import DataCon		( splitProductType_maybe, splitProductType )
 import NewDemand	( Demand(..), Keepity(..), DmdResult(..) ) 
-import PrelInfo		( realWorldPrimId, aBSENT_ERROR_ID )
+import PrelInfo		( realWorldPrimId, aBSENT_ERROR_ID, eRROR_CSTRING_ID )
 import TysPrim		( realWorldStatePrimTy )
 import TysWiredIn	( tupleCon )
 import Type		( Type, isUnLiftedType, mkFunTys,
 			  splitForAllTys, splitFunTys, splitNewType_maybe, isAlgType
 			)
+import Literal		( Literal(MachStr) )
 import BasicTypes	( Arity, Boxity(..) )
 import Var              ( Var, isId )
 import UniqSupply	( returnUs, thenUs, getUniqueUs, getUniquesUs, UniqSM )
@@ -219,7 +220,12 @@ mkWWargs fun_ty demands one_shots
       val_args	= zipWith4 mk_wrap_arg wrap_uniqs arg_tys demands one_shots
       wrap_args = tyvars ++ val_args
     in
-    ASSERT( not (null tyvars) || not (null arg_tys) )
+{-     ASSERT( not (null tyvars) || not (null arg_tys) ) -}
+    if (null tyvars) && (null arg_tys) then
+	pprTrace "mkWWargs" (ppr fun_ty $$ ppr demands) 
+		returnUs ([], id, id, fun_ty)
+	else
+
     mkWWargs new_fun_ty
 	     new_demands
 	     new_one_shots	`thenUs` \ (more_wrap_args, wrap_fn_args, work_fn_args, res_ty) ->
@@ -446,11 +452,14 @@ workerCase e		     arg alts = Case e arg alts
 \begin{code}
 mk_absent_let arg body
   | not (isUnLiftedType arg_ty)
-  = Let (NonRec arg (mkTyApps (Var aBSENT_ERROR_ID) [arg_ty])) body
+  = Let (NonRec arg abs_rhs) body
   | otherwise
   = panic "WwLib: haven't done mk_absent_let for primitives yet"
   where
     arg_ty = idType arg
+--    abs_rhs = mkTyApps (Var aBSENT_ERROR_ID) [arg_ty]
+    abs_rhs = mkApps (Var eRROR_CSTRING_ID) [Type arg_ty, Lit (MachStr (_PK_ msg))] 
+    msg     = "Oops!  Entered absent arg " ++ showSDocDebug (ppr arg <+> ppr (idType arg))
 
 mk_unpk_case arg unpk_args boxing_con boxing_tycon body
 	-- A data type
-- 
1.7.10.4