X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FMkId.lhs;h=9f9b3fe423b5a522557680857e2295cf721c7c52;hb=7df9b88b9e0565f438f16d8005526ffda80a1dbe;hp=7d472b12e9c64b4baf0868a555793b0a63dbe197;hpb=74d5597ec6069dab0aacb0b7c23d68b54d0f3bb4;p=ghc-hetmet.git diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 7d472b1..9f9b3fe 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -50,9 +50,9 @@ import Rules import TysPrim import TysWiredIn import PrelRules +import Unify import Type import TypeRep -import TcGadt import Coercion import TcType import CoreUtils @@ -355,7 +355,7 @@ mkDataConIds wrap_name wkr_name data_con 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 @@ -594,8 +594,8 @@ mkRecordSelId tycon field_label -- 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 @@ -638,13 +638,15 @@ mkRecordSelId tycon field_label -- 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..] @@ -658,14 +660,16 @@ mkRecordSelId tycon field_label -- 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 @@ -725,7 +729,7 @@ reboxProduct us ty 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 @@ -873,7 +877,7 @@ mkDictSelId no_unf name clas 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) @@ -1130,22 +1134,22 @@ another gun with which to shoot yourself in the foot. 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} @@ -1227,7 +1231,7 @@ realWorldPrimId -- :: State# RealWorld voidArgId :: Id voidArgId -- :: State# RealWorld - = mkSysLocal FSLIT("void") voidArgIdKey realWorldStatePrimTy + = mkSysLocal (fsLit "void") voidArgIdKey realWorldStatePrimTy \end{code} @@ -1310,10 +1314,14 @@ pcMiscPrelId name ty info -- 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 @@ -1323,7 +1331,7 @@ pc_bottoming_Id name ty -- 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}