X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FMkId.lhs;h=7499b7819659d6a9057e2eb47e3bb82119312f82;hb=6c1dbaa6fb592fc042af03f72a060ad0bb611db2;hp=0c0b01a3da88d9c631a865274fc0da251de1be59;hpb=9f703fe41b8300777dc8fcd8da94a3a082fdcfbb;p=ghc-hetmet.git diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 0c0b01a..7499b78 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -34,7 +34,7 @@ module MkId ( -- And some particular Ids; see below for why they are wired in wiredInIds, ghcPrimIds, unsafeCoerceId, realWorldPrimId, voidArgId, nullAddrId, seqId, - lazyId, lazyIdUnfolding, lazyIdKey, + lazyId, lazyIdUnfolding, lazyIdKey, mkRuntimeErrorApp, rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID, @@ -90,6 +90,7 @@ import Module %************************************************************************ \begin{code} +wiredInIds :: [Id] wiredInIds = [ -- These error-y things are wired in because we don't yet have -- a way to express in an interface file that the result type variable @@ -117,6 +118,7 @@ wiredInIds ] ++ ghcPrimIds -- These Ids are exported from GHC.Prim +ghcPrimIds :: [Id] ghcPrimIds = [ -- These can't be defined in Haskell, but they have -- perfectly reasonable unfoldings in Core @@ -460,17 +462,29 @@ For GADTs, we require that all constructors with a common field 'f' have the sam result type (modulo alpha conversion). [Checked in TcTyClsDecls.checkValidTyCon] E.g. data T where - T1 { f :: a } :: T [a] - T2 { f :: a, y :: b } :: T [a] -and now the selector takes that type as its argument: - f :: forall a. T [a] -> a - f t = case t of - T1 { f = v } -> v - T2 { f = v } -> v + T1 { f :: Maybe a } :: T [a] + T2 { f :: Maybe a, y :: b } :: T [a] + +and now the selector takes that result type as its argument: + f :: forall a. T [a] -> Maybe a + +Details: the "real" types of T1,T2 are: + T1 :: forall r a. (r~[a]) => a -> T r + T2 :: forall r a b. (r~[a]) => a -> b -> T r + +So the selector loooks like this: + f :: forall a. T [a] -> Maybe a + f (a:*) (t:T [a]) + = case t of + T1 c (g:[a]~[c]) (v:Maybe c) -> v `cast` Maybe (right (sym g)) + T2 c d (g:[a]~[c]) (v:Maybe c) (w:d) -> v `cast` Maybe (right (sym g)) + Note the forall'd tyvars of the selector are just the free tyvars of the result type; there may be other tyvars in the constructor's type (e.g. 'b' in T2). +Note the need for casts in the result! + Note [Selector running example] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It's OK to combine GADTs and type families. Here's a running example: @@ -639,9 +653,7 @@ mkRecordSelId tycon field_label -- 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 ) - mkReboxingAlt rebox_uniqs data_con (ex_tvs ++ co_tvs ++ arg_vs) rhs + = 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..] @@ -652,20 +664,21 @@ mkRecordSelId tycon field_label rebox_uniqs = map mkBuiltinUnique [rebox_base..] -- data T :: *->* where T1 { fld :: Maybe b } -> T [b] - -- Hence T1 :: forall a b. (a=[b]) => b -> T a + -- Hence T1 :: forall a b. (a~[b]) => b -> T a -- fld :: forall b. T [b] -> Maybe b -- fld = /\b.\(t:T[b]). case t of -- 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) - 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) + -- Generate the cast for the result + -- See Note [GADT record selectors] for why a cast is needed + in_scope_tvs = ex_tvs ++ co_tvs ++ data_tvs + reft = matchRefine in_scope_tvs (map (mkSymCoercion . mkTyVarTy) co_tvs) + rhs = case refineType reft (idType the_arg_id) of + Nothing -> Var the_arg_id + Just (co, data_ty) -> ASSERT2( data_ty `tcEqType` field_ty, + ppr data_con $$ ppr data_ty $$ ppr field_ty ) + Cast (Var the_arg_id) co field_vs = filter (not . isPredTy . idType) arg_vs the_arg_id = assoc "mkRecordSelId:mk_alt" @@ -957,7 +970,7 @@ unwrapFamInstScrut tycon args scrut %************************************************************************ %* * -\subsection{Primitive operations +\subsection{Primitive operations} %* * %************************************************************************ @@ -1141,15 +1154,15 @@ realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPri 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") +recSelErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "recSelError") recSelErrorIdKey rEC_SEL_ERROR_ID +runtimeErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "runtimeError") runtimeErrorIdKey rUNTIME_ERROR_ID +irrefutPatErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "irrefutPatError") irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID +recConErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "recConError") recConErrorIdKey rEC_CON_ERROR_ID +patErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "patError") patErrorIdKey pAT_ERROR_ID +noMethodBindingErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "noMethodBindingError") noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID nonExhaustiveGuardsErrorName - = mkWiredInIdName gHC_ERR (fsLit "nonExhaustiveGuardsError") + = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "nonExhaustiveGuardsError") nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID \end{code} @@ -1275,7 +1288,7 @@ mkRuntimeErrorApp mkRuntimeErrorApp err_id res_ty err_msg = mkApps (Var err_id) [Type res_ty, err_string] where - err_string = Lit (mkStringLit err_msg) + err_string = Lit (mkMachString err_msg) rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName @@ -1314,7 +1327,7 @@ errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy \begin{code} pcMiscPrelId :: Name -> Type -> IdInfo -> Id pcMiscPrelId name ty info - = mkVanillaGlobal name ty info + = mkVanillaGlobalWithInfo name ty info -- We lie and say the thing is imported; otherwise, we get into -- a mess with dependency analysis; e.g., core2stg may heave in -- random calls to GHCbase.unpackPS__. If GHCbase is the module