Commit 83a812bf authored by simonpj's avatar simonpj
Browse files

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

Make absent-arg errors more descriptive
parent 195abb24
......@@ -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
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment