X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FMkCore.lhs;h=a4977474315c2cefad537b4ba62e2d8041cbc7a1;hp=e7711375de5dc5fecdee5e4354be8573aa508916;hb=7fc01c4671980ea3c66d549c0ece4d82fd3f5ade;hpb=7e8cba32c6f045dde3db8a9ddc9831ec8ab4ed43 diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs index e771137..a497747 100644 --- a/compiler/coreSyn/MkCore.lhs +++ b/compiler/coreSyn/MkCore.lhs @@ -5,6 +5,7 @@ module MkCore ( mkCoreLet, mkCoreLets, mkCoreApp, mkCoreApps, mkCoreConApps, 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,17 +56,18 @@ import HscTypes import TysWiredIn import PrelNames +import TcType ( mkSigmaTy ) import Type -import TypeRep -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 ) @@ -95,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 @@ -120,14 +131,6 @@ mkCoreConApps con args = mkCoreApps (Var (dataConWorkId con)) args ----------- mk_val_app :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr -mk_val_app (Var f `App` Type ty1 `App` Type _ `App` arg1) arg2 _ res_ty - | f `hasKey` seqIdKey -- Note [Desugaring seq (1), (2)] - = Case arg1 case_bndr res_ty [(DEFAULT,[],arg2)] - where - case_bndr = case arg1 of - Var v1 | isLocalId v1 -> v1 -- Note [Desugaring seq (2) and (3)] - _ -> mkWildBinder ty1 - mk_val_app fun arg arg_ty _ -- See Note [CoreSyn let/app invariant] | not (needsCaseBinding arg_ty arg) = App fun arg -- The vastly common case @@ -135,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 -- @@ -145,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 @@ -167,69 +173,10 @@ mkIfThenElse guard then_expr else_expr (DataAlt trueDataCon, [], then_expr) ] \end{code} -Note [Desugaring seq (1)] cf Trac #1031 -~~~~~~~~~~~~~~~~~~~~~~~~~ - f x y = x `seq` (y `seq` (# x,y #)) - -The [CoreSyn let/app invariant] means that, other things being equal, because -the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus: - - f x y = case (y `seq` (# x,y #)) of v -> x `seq` v - -But that is bad for two reasons: - (a) we now evaluate y before x, and - (b) we can't bind v to an unboxed pair - -Seq is very, very special! So we recognise it right here, and desugar to - case x of _ -> case y of _ -> (# x,y #) - -Note [Desugaring seq (2)] cf Trac #2231 -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - let chp = case b of { True -> fst x; False -> 0 } - in chp `seq` ...chp... -Here the seq is designed to plug the space leak of retaining (snd x) -for too long. - -If we rely on the ordinary inlining of seq, we'll get - let chp = case b of { True -> fst x; False -> 0 } - case chp of _ { I# -> ...chp... } - -But since chp is cheap, and the case is an alluring contet, we'll -inline chp into the case scrutinee. Now there is only one use of chp, -so we'll inline a second copy. Alas, we've now ruined the purpose of -the seq, by re-introducing the space leak: - case (case b of {True -> fst x; False -> 0}) of - I# _ -> ...case b of {True -> fst x; False -> 0}... - -We can try to avoid doing this by ensuring that the binder-swap in the -case happens, so we get his at an early stage: - case chp of chp2 { I# -> ...chp2... } -But this is fragile. The real culprit is the source program. Perhaps we -should have said explicitly - let !chp2 = chp in ...chp2... - -But that's painful. So the code here does a little hack to make seq -more robust: a saturated application of 'seq' is turned *directly* into -the case expression. So we desugar to: - let chp = case b of { True -> fst x; False -> 0 } - case chp of chp { I# -> ...chp... } -Notice the shadowing of the case binder! And now all is well. - -The reason it's a hack is because if you define mySeq=seq, the hack -won't work on mySeq. - -Note [Desugaring seq (3)] cf Trac #2409 -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The isLocalId ensures that we don't turn - True `seq` e -into - case True of True { ... } -which stupidly tries to bind the datacon 'True'. -\begin{code} --- The functions from this point don't really do anything cleverer than --- their counterparts in CoreSyn, but they are here for consistency +The functions from this point don't really do anything cleverer than +their counterparts in CoreSyn, but they are here for consistency +\begin{code} -- | Create a lambda where the given expression has a number of variables -- bound over it. The leftmost binder is that bound by the outermost -- lambda in the result @@ -405,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 @@ -414,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) @@ -434,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} %************************************************************************ @@ -478,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 ] @@ -539,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} @@ -620,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} +