import TysPrim
import TysWiredIn
import PrelRules
+import Unify
import Type
import TypeRep
-import TcGadt
import Coercion
import TcType
import CoreUtils
mkCoVarLocals i [] = ([],i)
mkCoVarLocals i (x:xs) = let (ys,j) = mkCoVarLocals (i+1) xs
- y = mkCoVar (mkSysTvName (mkBuiltinUnique i) FSLIT("dc_co")) x
+ y = mkCoVar (mkSysTvName (mkBuiltinUnique i) (fsLit "dc_co")) x
in (y:ys,j)
mk_case
-- Allocate Ids. We do it a funny way round because field_dict_tys is
-- almost always empty. Also note that we use max_dict_tys
-- rather than n_dict_tys, because the latter gives an infinite loop:
- -- n_dict tys depends on the_alts, which depens on arg_ids, which depends
- -- on arity, which depends on n_dict tys. Sigh! Mega sigh!
+ -- n_dict tys depends on the_alts, which depens on arg_ids, which
+ -- depends on arity, which depends on n_dict tys. Sigh! Mega sigh!
stupid_dict_ids = mkTemplateLocalsNum 1 stupid_dict_tys
max_stupid_dicts = length (tyConStupidTheta tycon)
field_dict_base = max_stupid_dicts + 1
-- foo :: forall a. T -> a -> a
-- foo = /\a. \t:T. case t of { MkT f -> f a }
- mk_alt data_con
- = ASSERT2( data_ty `tcEqType` field_ty, ppr data_con $$ ppr data_ty $$ ppr field_ty )
+ mk_alt data_con
+ = ASSERT2( data_ty `tcEqType` field_ty,
+ ppr data_con $$ ppr data_ty $$ ppr field_ty )
mkReboxingAlt rebox_uniqs data_con (ex_tvs ++ co_tvs ++ arg_vs) rhs
where
-- get pattern binders with types appropriately instantiated
arg_uniqs = map mkBuiltinUnique [arg_base..]
- (ex_tvs, co_tvs, arg_vs) = dataConOrigInstPat arg_uniqs data_con scrut_ty_args
+ (ex_tvs, co_tvs, arg_vs) = dataConOrigInstPat arg_uniqs data_con
+ scrut_ty_args
rebox_base = arg_base + length ex_tvs + length co_tvs + length arg_vs
rebox_uniqs = map mkBuiltinUnique [rebox_base..]
-- T1 b' (c : [b]=[b']) (x:Maybe b')
-- -> x `cast` Maybe (sym (right c))
-
-- Generate the refinement for b'=b,
-- and apply to (Maybe b'), to get (Maybe b)
- Succeeded refinement = gadtRefine emptyRefinement ex_tvs co_tvs
- the_arg_id_ty = idType the_arg_id
- (rhs, data_ty) = case refineType refinement the_arg_id_ty of
- Just (co, data_ty) -> (Cast (Var the_arg_id) co, data_ty)
- Nothing -> (Var the_arg_id, the_arg_id_ty)
+ reft = matchRefine co_tvs
+ the_arg_id_ty = idType the_arg_id
+ (rhs, data_ty) =
+ case refineType reft the_arg_id_ty of
+ Just (co, data_ty) -> (Cast (Var the_arg_id) co, data_ty)
+ Nothing -> (Var the_arg_id, the_arg_id_ty)
field_vs = filter (not . isPredTy . idType) arg_vs
- the_arg_id = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` field_vs) field_label
+ the_arg_id = assoc "mkRecordSelId:mk_alt"
+ (field_lbls `zip` field_vs) field_label
field_lbls = dataConFieldLabels data_con
error_expr = mkRuntimeErrorApp rEC_SEL_ERROR_ID field_ty full_msg
us' = dropList con_arg_tys us
- arg_ids = zipWith (mkSysLocal FSLIT("rb")) us con_arg_tys
+ arg_ids = zipWith (mkSysLocal (fsLit "rb")) us con_arg_tys
bind_rhs = mkProductBox arg_ids ty
recover the original type signature from the class op selector.
\begin{code}
-mkDictSelId :: Name -> Class -> Id
-mkDictSelId name clas
+mkDictSelId :: Bool -- True <=> don't include the unfolding
+ -- Little point on imports without -O, because the
+ -- dictionary itself won't be visible
+ -> Name -> Class -> Id
+mkDictSelId no_unf name clas
= mkGlobalId (ClassOpId clas) name sel_ty info
where
sel_ty = mkForAllTys tyvars (mkFunTy (idType dict_id) (idType the_arg_id))
info = noCafIdInfo
`setArityInfo` 1
- `setUnfoldingInfo` mkTopUnfolding rhs
`setAllStrictnessInfo` Just strict_sig
+ `setUnfoldingInfo` (if no_unf then noUnfolding
+ else mkTopUnfolding rhs)
-- We no longer use 'must-inline' on record selectors. They'll
-- inline like crazy if they scrutinise a constructor
mkCoVarLocals i [] = ([],i)
mkCoVarLocals i (x:xs) = let (ys,j) = mkCoVarLocals (i+1) xs
- y = mkCoVar (mkSysTvName (mkBuiltinUnique i) FSLIT("dc_co")) x
+ y = mkCoVar (mkSysTvName (mkBuiltinUnique i) (fsLit "dc_co")) x
in (y:ys,j)
rhs = mkLams tyvars (Lam dict_id rhs_body)
mkWiredInIdName mod fs uniq id
= mkWiredInName mod (mkOccNameFS varName fs) uniq (AnId id) UserSyntax
-unsafeCoerceName = mkWiredInIdName gHC_PRIM FSLIT("unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId
-nullAddrName = mkWiredInIdName gHC_PRIM FSLIT("nullAddr#") nullAddrIdKey nullAddrId
-seqName = mkWiredInIdName gHC_PRIM FSLIT("seq") seqIdKey seqId
-realWorldName = mkWiredInIdName gHC_PRIM FSLIT("realWorld#") realWorldPrimIdKey realWorldPrimId
-lazyIdName = mkWiredInIdName gHC_BASE FSLIT("lazy") lazyIdKey lazyId
-
-errorName = mkWiredInIdName gHC_ERR FSLIT("error") errorIdKey eRROR_ID
-recSelErrorName = mkWiredInIdName gHC_ERR FSLIT("recSelError") recSelErrorIdKey rEC_SEL_ERROR_ID
-runtimeErrorName = mkWiredInIdName gHC_ERR FSLIT("runtimeError") runtimeErrorIdKey rUNTIME_ERROR_ID
-irrefutPatErrorName = mkWiredInIdName gHC_ERR FSLIT("irrefutPatError") irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID
-recConErrorName = mkWiredInIdName gHC_ERR FSLIT("recConError") recConErrorIdKey rEC_CON_ERROR_ID
-patErrorName = mkWiredInIdName gHC_ERR FSLIT("patError") patErrorIdKey pAT_ERROR_ID
-noMethodBindingErrorName = mkWiredInIdName gHC_ERR FSLIT("noMethodBindingError")
+unsafeCoerceName = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId
+nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId
+seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId
+realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPrimIdKey realWorldPrimId
+lazyIdName = mkWiredInIdName gHC_BASE (fsLit "lazy") lazyIdKey lazyId
+
+errorName = mkWiredInIdName gHC_ERR (fsLit "error") errorIdKey eRROR_ID
+recSelErrorName = mkWiredInIdName gHC_ERR (fsLit "recSelError") recSelErrorIdKey rEC_SEL_ERROR_ID
+runtimeErrorName = mkWiredInIdName gHC_ERR (fsLit "runtimeError") runtimeErrorIdKey rUNTIME_ERROR_ID
+irrefutPatErrorName = mkWiredInIdName gHC_ERR (fsLit "irrefutPatError") irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID
+recConErrorName = mkWiredInIdName gHC_ERR (fsLit "recConError") recConErrorIdKey rEC_CON_ERROR_ID
+patErrorName = mkWiredInIdName gHC_ERR (fsLit "patError") patErrorIdKey pAT_ERROR_ID
+noMethodBindingErrorName = mkWiredInIdName gHC_ERR (fsLit "noMethodBindingError")
noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID
nonExhaustiveGuardsErrorName
- = mkWiredInIdName gHC_ERR FSLIT("nonExhaustiveGuardsError")
+ = mkWiredInIdName gHC_ERR (fsLit "nonExhaustiveGuardsError")
nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID
\end{code}
voidArgId :: Id
voidArgId -- :: State# RealWorld
- = mkSysLocal FSLIT("void") voidArgIdKey realWorldStatePrimTy
+ = mkSysLocal (fsLit "void") voidArgIdKey realWorldStatePrimTy
\end{code}
-- will be in "the right place" to be in scope.
pc_bottoming_Id :: Name -> Type -> Id
+-- Function of arity 1, which diverges after being given one argument
pc_bottoming_Id name ty
= pcMiscPrelId name ty bottoming_info
where
bottoming_info = vanillaIdInfo `setAllStrictnessInfo` 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
-- any pc_bottoming_Id will itself have CafRefs, which bloats
-- SRTs.
- strict_sig = mkStrictSig (mkTopDmdType [evalDmd] BotRes)
+ strict_sig = mkStrictSig (mkTopDmdType [evalDmd] BotRes)
-- These "bottom" out, no matter what their arguments
\end{code}
projects / ghc-hetmet.git / blobdiff