X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FMkId.lhs;h=8448409707f404579e3769d2ce4df776b050e48d;hb=11818da753b5d1a1f997be423d7e5b6e09b9f9e5;hp=3ea509172387375179d755a3bd8d67a8dbf3ab3d;hpb=53a0d2626c9dbe71026e985ae34bdf4fdc26d094;p=ghc-hetmet.git diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 3ea5091..8448409 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 -w #-} +{-# 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 ( @@ -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 @@ -544,7 +544,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. @@ -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..] @@ -656,17 +658,18 @@ mkRecordSelId tycon field_label -- 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 @@ -726,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 @@ -799,6 +802,7 @@ mkReboxingAlt us con args rhs | otherwise = let (binds, args') = go args stricts us in (binds, arg:args') + go (_ : _) [] _ = panic "mkReboxingAlt" \end{code} @@ -827,8 +831,11 @@ at the outside. When dealing with classes it's very convenient to 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)) @@ -840,8 +847,9 @@ mkDictSelId name clas 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 @@ -869,7 +877,7 @@ mkDictSelId 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) @@ -1126,26 +1134,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 (fsLit "recSelError") recSelErrorIdKey rEC_SEL_ERROR_ID +runtimeErrorName = mkWiredInIdName cONTROL_EXCEPTION (fsLit "runtimeError") runtimeErrorIdKey rUNTIME_ERROR_ID +irrefutPatErrorName = mkWiredInIdName cONTROL_EXCEPTION (fsLit "irrefutPatError") irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID +recConErrorName = mkWiredInIdName cONTROL_EXCEPTION (fsLit "recConError") recConErrorIdKey rEC_CON_ERROR_ID +patErrorName = mkWiredInIdName cONTROL_EXCEPTION (fsLit "patError") patErrorIdKey pAT_ERROR_ID +noMethodBindingErrorName = mkWiredInIdName cONTROL_EXCEPTION (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} \begin{code} +------------------------------------------------ -- unsafeCoerce# :: forall a b. a -> b unsafeCoerceId = pcMiscPrelId unsafeCoerceName ty info @@ -1159,17 +1168,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 @@ -1179,6 +1194,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 -- @@ -1190,8 +1207,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) @@ -1221,8 +1237,9 @@ realWorldPrimId -- :: State# RealWorld -- which in turn makes INLINE things applied to realWorld# likely -- to be inlined +voidArgId :: Id voidArgId -- :: State# RealWorld - = mkSysLocal FSLIT("void") voidArgIdKey realWorldStatePrimTy + = mkSysLocal (fsLit "void") voidArgIdKey realWorldStatePrimTy \end{code} @@ -1269,7 +1286,11 @@ nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName -- The runtime error Ids take a UTF8-encoded string as argument + +mkRuntimeErrorId :: Name -> Id mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy + +runtimeErrorTy :: Type runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy) \end{code} @@ -1300,10 +1321,15 @@ pcMiscPrelId name ty info -- being compiled, then it's just a matter of luck if the definition -- 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 @@ -1313,7 +1339,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}