-- * Constructing normal syntax
mkCoreLet, mkCoreLets,
mkCoreApp, mkCoreApps, mkCoreConApps,
- mkCoreLams, mkWildCase, mkWildBinder, mkIfThenElse,
+ mkCoreLams, mkWildCase, mkIfThenElse,
+ mkWildValBinder, mkWildEvBinder,
-- * Constructing boxed literals
mkWordExpr, mkWordExprWord,
mkChunkified,
-- * Constructing small tuples
- mkCoreVarTup, mkCoreVarTupTy,
- mkCoreTup, mkCoreTupTy,
+ mkCoreVarTup, mkCoreVarTupTy, mkCoreTup,
-- * Constructing big tuples
mkBigCoreVarTup, mkBigCoreVarTupTy,
-- * Constructing list expressions
mkNilExpr, mkConsExpr, mkListExpr,
- mkFoldrExpr, mkBuildExpr
+ mkFoldrExpr, mkBuildExpr,
+
+ -- * Error Ids
+ mkRuntimeErrorApp, mkImpossibleExpr, errorIds,
+ rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID,
+ nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,
+ pAT_ERROR_ID, eRROR_ID, rEC_SEL_ERROR_ID, aBSENT_ERROR_ID
) where
#include "HsVersions.h"
import Id
-import Var ( setTyVarUnique )
+import IdInfo
+import Var ( EvVar, mkWildCoVar, setTyVarUnique )
import CoreSyn
import CoreUtils ( exprType, needsCaseBinding, bindNonRec )
import TysWiredIn
import PrelNames
+import TcType ( mkSigmaTy )
import Type
-import TysPrim ( alphaTyVar )
+import TysPrim
import DataCon ( DataCon, dataConWorkId )
-
+import Demand
+import Name
+import Outputable
import FastString
import UniqSupply
import Unique ( mkBuiltinUnique )
import BasicTypes
import Util ( notNull, zipEqual )
-import Panic
import Constants
import Data.Char ( ord )
-- Check the invariant that the arg of an App is ok-for-speculation if unlifted
-- See CoreSyn Note [CoreSyn let/app invariant]
mkCoreApp fun (Type ty) = App fun (Type ty)
-mkCoreApp fun arg = mk_val_app fun arg arg_ty res_ty
+mkCoreApp fun arg = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg )
+ mk_val_app fun arg arg_ty res_ty
where
- (arg_ty, res_ty) = splitFunTy (exprType fun)
+ fun_ty = exprType fun
+ (arg_ty, res_ty) = splitFunTy fun_ty
-- | Construct an expression which represents the application of a number of
-- expressions to another. The leftmost expression in the list is applied first
mkCoreApps :: CoreExpr -> [CoreExpr] -> CoreExpr
-- Slightly more efficient version of (foldl mkCoreApp)
-mkCoreApps fun args
- = go fun (exprType fun) args
+mkCoreApps orig_fun orig_args
+ = go orig_fun (exprType orig_fun) orig_args
where
go fun _ [] = fun
go fun fun_ty (Type ty : args) = go (App fun (Type ty)) (applyTy fun_ty ty) args
- go fun fun_ty (arg : args) = go (mk_val_app fun arg arg_ty res_ty) res_ty args
+ go fun fun_ty (arg : args) = ASSERT2( isFunTy fun_ty, ppr fun_ty $$ ppr orig_fun $$ ppr orig_args )
+ go (mk_val_app fun arg arg_ty res_ty) res_ty args
where
(arg_ty, res_ty) = splitFunTy fun_ty
mk_val_app fun arg arg_ty res_ty
= Case arg arg_id res_ty [(DEFAULT,[],App fun (Var arg_id))]
where
- arg_id = mkWildBinder arg_ty
+ arg_id = mkWildValBinder arg_ty
-- Lots of shadowing, but it doesn't matter,
-- because 'fun ' should not have a free wild-id
--
-- is if you take apart this case expression, and pass a
-- fragmet of it as the fun part of a 'mk_val_app'.
+mkWildEvBinder :: PredType -> EvVar
+mkWildEvBinder pred@(EqPred {}) = mkWildCoVar (mkPredTy pred)
+mkWildEvBinder pred = mkWildValBinder (mkPredTy pred)
-- | Make a /wildcard binder/. This is typically used when you need a binder
-- that you expect to use only at a *binding* site. Do not use it at
-- occurrence sites because it has a single, fixed unique, and it's very
-- easy to get into difficulties with shadowing. That's why it is used so little.
-mkWildBinder :: Type -> Id
-mkWildBinder ty = mkSysLocal (fsLit "wild") (mkBuiltinUnique 1) ty
+mkWildValBinder :: Type -> Id
+mkWildValBinder ty = mkSysLocal (fsLit "wild") (mkBuiltinUnique 1) ty
mkWildCase :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr
-- Make a case expression whose case binder is unused
-- The alts should not have any occurrences of WildId
mkWildCase scrut scrut_ty res_ty alts
- = Case scrut (mkWildBinder scrut_ty) res_ty alts
+ = Case scrut (mkWildValBinder scrut_ty) res_ty alts
mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
mkIfThenElse guard then_expr else_expr
-- | Bulid the type of a small tuple that holds the specified variables
mkCoreVarTupTy :: [Id] -> Type
-mkCoreVarTupTy ids = mkCoreTupTy (map idType ids)
+mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids)
-- | Build a small tuple holding the specified expressions
mkCoreTup :: [CoreExpr] -> CoreExpr
mkCoreTup cs = mkConApp (tupleCon Boxed (length cs))
(map (Type . exprType) cs ++ cs)
--- | Build the type of a small tuple that holds the specified type of thing
-mkCoreTupTy :: [Type] -> Type
-mkCoreTupTy [ty] = ty
-mkCoreTupTy tys = mkTupleTy Boxed (length tys) tys
-
-
-- | Build a big tuple holding the specified variables
mkBigCoreVarTup :: [Id] -> CoreExpr
mkBigCoreVarTup ids = mkBigCoreTup (map Var ids)
-- | Build the type of a big tuple that holds the specified type of thing
mkBigCoreTupTy :: [Type] -> Type
-mkBigCoreTupTy = mkChunkified mkCoreTupTy
+mkBigCoreTupTy = mkChunkified mkBoxedTupleTy
\end{code}
%************************************************************************
mk_tup_sel vars_s the_var = mkSmallTupleSelector group the_var tpl_v $
mk_tup_sel (chunkify tpl_vs) tpl_v
where
- tpl_tys = [mkCoreTupTy (map idType gp) | gp <- vars_s]
+ tpl_tys = [mkBoxedTupleTy (map idType gp) | gp <- vars_s]
tpl_vs = mkTemplateLocals tpl_tys
[(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s,
the_var `elem` gp ]
one_tuple_case chunk_vars (us, vs, body)
= let (us1, us2) = splitUniqSupply us
scrut_var = mkSysLocal (fsLit "ds") (uniqFromSupply us1)
- (mkCoreTupTy (map idType chunk_vars))
+ (mkBoxedTupleTy (map idType chunk_vars))
body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var)
in (us2, scrut_var:vs, body')
\end{code}
newTyVars tyvar_tmpls = do
uniqs <- getUniquesM
return (zipWith setTyVarUnique tyvar_tmpls uniqs)
-\end{code}
\ No newline at end of file
+\end{code}
+
+
+%************************************************************************
+%* *
+ Error expressions
+%* *
+%************************************************************************
+
+\begin{code}
+mkRuntimeErrorApp
+ :: Id -- Should be of type (forall a. Addr# -> a)
+ -- where Addr# points to a UTF8 encoded string
+ -> Type -- The type to instantiate 'a'
+ -> String -- The string to print
+ -> CoreExpr
+
+mkRuntimeErrorApp err_id res_ty err_msg
+ = mkApps (Var err_id) [Type res_ty, err_string]
+ where
+ err_string = Lit (mkMachString err_msg)
+
+mkImpossibleExpr :: Type -> CoreExpr
+mkImpossibleExpr res_ty
+ = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative"
+\end{code}
+
+%************************************************************************
+%* *
+ Error Ids
+%* *
+%************************************************************************
+
+GHC randomly injects these into the code.
+
+@patError@ is just a version of @error@ for pattern-matching
+failures. It knows various ``codes'' which expand to longer
+strings---this saves space!
+
+@absentErr@ is a thing we put in for ``absent'' arguments. They jolly
+well shouldn't be yanked on, but if one is, then you will get a
+friendly message from @absentErr@ (rather than a totally random
+crash).
+
+@parError@ is a special version of @error@ which the compiler does
+not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@
+templates, but we don't ever expect to generate code for it.
+
+\begin{code}
+errorIds :: [Id]
+errorIds
+ = [ eRROR_ID, -- This one isn't used anywhere else in the compiler
+ -- But we still need it in wiredInIds so that when GHC
+ -- compiles a program that mentions 'error' we don't
+ -- import its type from the interface file; we just get
+ -- the Id defined here. Which has an 'open-tyvar' type.
+
+ rUNTIME_ERROR_ID,
+ iRREFUT_PAT_ERROR_ID,
+ nON_EXHAUSTIVE_GUARDS_ERROR_ID,
+ nO_METHOD_BINDING_ERROR_ID,
+ pAT_ERROR_ID,
+ rEC_CON_ERROR_ID,
+ rEC_SEL_ERROR_ID,
+ aBSENT_ERROR_ID ]
+
+recSelErrorName, runtimeErrorName, absentErrorName :: Name
+irrefutPatErrorName, recConErrorName, patErrorName :: Name
+nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name
+
+recSelErrorName = err_nm "recSelError" recSelErrorIdKey rEC_SEL_ERROR_ID
+absentErrorName = err_nm "absentError" absentErrorIdKey aBSENT_ERROR_ID
+runtimeErrorName = err_nm "runtimeError" runtimeErrorIdKey rUNTIME_ERROR_ID
+irrefutPatErrorName = err_nm "irrefutPatError" irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID
+recConErrorName = err_nm "recConError" recConErrorIdKey rEC_CON_ERROR_ID
+patErrorName = err_nm "patError" patErrorIdKey pAT_ERROR_ID
+
+noMethodBindingErrorName = err_nm "noMethodBindingError"
+ noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID
+nonExhaustiveGuardsErrorName = err_nm "nonExhaustiveGuardsError"
+ nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID
+
+err_nm :: String -> Unique -> Id -> Name
+err_nm str uniq id = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit str) uniq id
+
+rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, iRREFUT_PAT_ERROR_ID, rEC_CON_ERROR_ID :: Id
+pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id
+rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName
+rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName
+iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorName
+rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName
+pAT_ERROR_ID = mkRuntimeErrorId patErrorName
+nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName
+nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName
+
+aBSENT_ERROR_ID :: Id
+-- Not bottoming; no unfolding! See Note [Absent error Id] in WwLib
+aBSENT_ERROR_ID = mkVanillaGlobal absentErrorName runtimeErrorTy
+
+mkRuntimeErrorId :: Name -> Id
+mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy
+
+runtimeErrorTy :: Type
+-- The runtime error Ids take a UTF8-encoded string as argument
+runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy)
+\end{code}
+
+\begin{code}
+errorName :: Name
+errorName = mkWiredInIdName gHC_ERR (fsLit "error") errorIdKey eRROR_ID
+
+eRROR_ID :: Id
+eRROR_ID = pc_bottoming_Id errorName errorTy
+
+errorTy :: Type
+errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
+ -- Notice the openAlphaTyVar. It says that "error" can be applied
+ -- to unboxed as well as boxed types. This is OK because it never
+ -- returns, so the return type is irrelevant.
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Utilities}
+%* *
+%************************************************************************
+
+\begin{code}
+pc_bottoming_Id :: Name -> Type -> Id
+-- Function of arity 1, which diverges after being given one argument
+pc_bottoming_Id name ty
+ = mkVanillaGlobalWithInfo name ty bottoming_info
+ where
+ bottoming_info = vanillaIdInfo `setStrictnessInfo` 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
+ -- In due course we may arrange that these error-y things are
+ -- regarded by the GC as permanently live, in which case we
+ -- can give them NoCaf info. As it is, any function that calls
+ -- any pc_bottoming_Id will itself have CafRefs, which bloats
+ -- SRTs.
+
+ strict_sig = mkStrictSig (mkTopDmdType [evalDmd] BotRes)
+ -- These "bottom" out, no matter what their arguments
+\end{code}
+
projects / ghc-hetmet.git / blobdiff