X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FMkId.lhs;h=637d4c5b9fb214703574bfa750a019af805fe033;hp=a9c4e02e6c4c1370be03e0e3bf0b518b8e407755;hb=4e36a8b19e25e69d28c43f8d09d5ecc02329948d;hpb=3d5970436af5ab73957278671059e00d1a52c616 diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index a9c4e02..637d4c5 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -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 @@ -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 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} \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} @@ -1314,10 +1322,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 +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}