X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FMkCore.lhs;h=a4977474315c2cefad537b4ba62e2d8041cbc7a1;hp=f67c78ad0526d4f2380fb38b00ea7abd024437c7;hb=7fc01c4671980ea3c66d549c0ece4d82fd3f5ade;hpb=703ca1542c8e0983cc9d8eebce6e9f3dd3fd71e2 diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs index f67c78a..a497747 100644 --- a/compiler/coreSyn/MkCore.lhs +++ b/compiler/coreSyn/MkCore.lhs @@ -4,7 +4,8 @@ module MkCore ( -- * Constructing normal syntax mkCoreLet, mkCoreLets, mkCoreApp, mkCoreApps, mkCoreConApps, - mkCoreLams, mkWildCase, mkWildBinder, mkIfThenElse, + mkCoreLams, mkWildCase, mkIfThenElse, + mkWildValBinder, mkWildEvBinder, -- * Constructing boxed literals mkWordExpr, mkWordExprWord, @@ -18,8 +19,7 @@ module MkCore ( mkChunkified, -- * Constructing small tuples - mkCoreVarTup, mkCoreVarTupTy, - mkCoreTup, mkCoreTupTy, + mkCoreVarTup, mkCoreVarTupTy, mkCoreTup, -- * Constructing big tuples mkBigCoreVarTup, mkBigCoreVarTupTy, @@ -33,13 +33,20 @@ module MkCore ( -- * 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 ) @@ -49,16 +56,18 @@ import HscTypes 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 ) @@ -94,20 +103,23 @@ mkCoreApp :: CoreExpr -> CoreExpr -> CoreExpr -- 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 @@ -126,7 +138,7 @@ mk_val_app fun arg arg_ty _ -- See Note [CoreSyn let/app invariant] 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 -- @@ -136,19 +148,22 @@ mk_val_app fun arg arg_ty res_ty -- 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 @@ -337,7 +352,7 @@ mkCoreVarTup ids = mkCoreTup (map Var ids) -- | 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 @@ -346,12 +361,6 @@ mkCoreTup [c] = c 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) @@ -366,7 +375,7 @@ mkBigCoreTup = mkChunkified mkCoreTup -- | 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} %************************************************************************ @@ -410,7 +419,7 @@ mkTupleSelector vars the_var scrut_var scrut 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 ] @@ -471,7 +480,7 @@ mkTupleCase uniqs vars body scrut_var scrut 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} @@ -552,4 +561,154 @@ mkBuildExpr elt_ty mk_build_inside = do 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} +