X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FMkId.lhs;h=be838351baba97022d94d7f55c3b5e6bc4ad0d91;hp=a9c4e02e6c4c1370be03e0e3bf0b518b8e407755;hb=a15972f1b72500a0bf0edca948314ea9fbc46ec3;hpb=3d5970436af5ab73957278671059e00d1a52c616 diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index a9c4e02..be83835 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -1,4 +1,4 @@ -\% +% % (c) The University of Glasgow 2006 % (c) The AQUA Project, Glasgow University, 1998 % @@ -6,17 +6,17 @@ This module contains definitions for the IdInfo for things that have a standard form, namely: -* data constructors -* record selectors -* method and superclass selectors -* primitive operations +- data constructors +- record selectors +- method and superclass selectors +- primitive operations \begin{code} {-# OPTIONS -fno-warn-missing-signatures #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- -- for details module MkId ( @@ -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 @@ -186,7 +188,7 @@ tyConFamInst_maybe). A coercion allows you to move between representation and family type. It is accessible from :R123Map via tyConFamilyCoercion_maybe and has kind - Co123Map a b v :: {Map (a, b) v :=: :R123Map a b v} + Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v} The wrapper and worker of MapPair get the types @@ -292,7 +294,8 @@ mkDataConIds wrap_name wkr_name data_con id_arg1 = mkTemplateLocal 1 (if null orig_arg_tys - then ASSERT(not (null $ dataConDictTheta data_con)) mkPredTy $ head (dataConDictTheta data_con) + then ASSERT(not (null $ dataConDictTheta data_con)) + mkPredTy $ head (dataConDictTheta data_con) else head orig_arg_tys ) @@ -332,13 +335,13 @@ mkDataConIds wrap_name wkr_name data_con -- ...(let w = C x in ...(w p q)...)... -- we want to see that w is strict in its two arguments - wrap_unf = mkTopUnfolding $ Note InlineMe $ - mkLams wrap_tvs $ - mkLams eq_args $ - mkLams dict_args $ mkLams id_args $ - foldr mk_case con_app - (zip (dict_args ++ id_args) all_strict_marks) - i3 [] + wrap_unf = mkImplicitUnfolding $ Note InlineMe $ + mkLams wrap_tvs $ + mkLams eq_args $ + mkLams dict_args $ mkLams id_args $ + foldr mk_case con_app + (zip (dict_args ++ id_args) all_strict_marks) + i3 [] con_app _ rep_ids = wrapFamInstBody tycon res_ty_args $ Var wrk_id `mkTyApps` res_ty_args @@ -355,7 +358,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 @@ -460,17 +463,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: @@ -544,7 +559,7 @@ mkRecordSelId tycon field_label data_tv_set = tyVarsOfType data_ty data_tvs = varSetElems data_tv_set - -- *Very* tiresomely, the selectors are (unnecessarily!) overloaded over + -- _Very_ tiresomely, the selectors are (unnecessarily!) overloaded over -- just the dictionaries in the types of the constructors that contain -- the relevant field. [The Report says that pattern matching on a -- constructor gives the same constraints as applying it.] Urgh. @@ -588,9 +603,11 @@ mkRecordSelId tycon field_label info = noCafIdInfo `setCafInfo` caf_info `setArityInfo` arity - `setUnfoldingInfo` mkTopUnfolding rhs_w_str + `setUnfoldingInfo` unfolding `setAllStrictnessInfo` Just strict_sig + unfolding = mkImplicitUnfolding rhs_w_str + -- 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: @@ -639,9 +656,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 +667,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" @@ -729,7 +745,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 @@ -849,7 +865,7 @@ mkDictSelId no_unf name clas `setArityInfo` 1 `setAllStrictnessInfo` Just strict_sig `setUnfoldingInfo` (if no_unf then noUnfolding - else mkTopUnfolding rhs) + else mkImplicitUnfolding rhs) -- We no longer use 'must-inline' on record selectors. They'll -- inline like crazy if they scrutinise a constructor @@ -877,7 +893,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) @@ -957,7 +973,7 @@ unwrapFamInstScrut tycon args scrut %************************************************************************ %* * -\subsection{Primitive operations +\subsection{Primitive operations} %* * %************************************************************************ @@ -1134,26 +1150,27 @@ 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 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} \begin{code} +------------------------------------------------ -- unsafeCoerce# :: forall a b. a -> b unsafeCoerceId = pcMiscPrelId unsafeCoerceName ty info @@ -1167,17 +1184,23 @@ unsafeCoerceId rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $ Cast (Var x) (mkUnsafeCoercion openAlphaTy openBetaTy) +------------------------------------------------ +nullAddrId :: Id -- nullAddr# :: Addr# -- The reason is is here is because we don't provide -- a way to write this literal in Haskell. -nullAddrId - = pcMiscPrelId nullAddrName addrPrimTy info +nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info where info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding (Lit nullAddrLit) -seqId - = pcMiscPrelId seqName ty info +------------------------------------------------ +seqId :: Id +-- 'seq' is very special. See notes with +-- See DsUtils.lhs Note [Desugaring seq (1)] and +-- Note [Desugaring seq (2)] and +-- Fixity is set in LoadIface.ghcPrimIface +seqId = pcMiscPrelId seqName ty info where info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs @@ -1187,6 +1210,8 @@ seqId [x,y] = mkTemplateLocals [alphaTy, openBetaTy] rhs = mkLams [alphaTyVar,openBetaTyVar,x,y] (Case (Var x) x openBetaTy [(DEFAULT, [], Var y)]) +------------------------------------------------ +lazyId :: Id -- lazy :: forall a?. a? -> a? (i.e. works for unboxed types too) -- Used to lazify pseq: pseq a b = a `seq` lazy b -- @@ -1198,8 +1223,7 @@ seqId -- (see WorkWrap.wwExpr) -- We could use inline phases to do this, but that would be vulnerable to changes in -- phase numbering....we must inline precisely after strictness analysis. -lazyId - = pcMiscPrelId lazyIdName ty info +lazyId = pcMiscPrelId lazyIdName ty info where info = noCafIdInfo ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy) @@ -1231,7 +1255,7 @@ realWorldPrimId -- :: State# RealWorld voidArgId :: Id voidArgId -- :: State# RealWorld - = mkSysLocal FSLIT("void") voidArgIdKey realWorldStatePrimTy + = mkSysLocal (fsLit "void") voidArgIdKey realWorldStatePrimTy \end{code} @@ -1267,7 +1291,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 @@ -1306,7 +1330,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 @@ -1314,10 +1338,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 @@ -1327,7 +1355,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}