[project @ 2001-07-24 15:57:27 by simonpj]

Make absent-arg errors more descriptive

diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs
index b3c6be3..0d5bcec 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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