X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2FbasicTypes%2FMkId.lhs;h=eb85111d4df092062eec74838dcc334f13ea354e;hb=6084fb5517da34f65034370a3695e2af3b85ce2b;hp=3e63c31b221348c1a831833e14fbd3a2cd2035be;hpb=f3a381ed3888bf634e91400e52204ab2252567d2;p=ghc-hetmet.git diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 3e63c31..eb85111 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 ( @@ -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. @@ -729,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 @@ -877,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) @@ -1134,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 @@ -1167,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 @@ -1187,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 -- @@ -1198,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) @@ -1231,7 +1239,7 @@ realWorldPrimId -- :: State# RealWorld voidArgId :: Id voidArgId -- :: State# RealWorld - = mkSysLocal FSLIT("void") voidArgIdKey realWorldStatePrimTy + = mkSysLocal (fsLit "void") voidArgIdKey realWorldStatePrimTy \end{code} @@ -1306,7 +1314,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