diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/basicTypes/MkId.lhs | 50 | ||||
| -rw-r--r-- | compiler/prelude/PrelNames.lhs | 5 | ||||
| -rw-r--r-- | compiler/typecheck/TcExpr.lhs | 17 |
3 files changed, 48 insertions, 24 deletions
diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 604163fd46..38922fcd00 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -125,7 +125,7 @@ is right here. \begin{code} wiredInIds :: [Id] wiredInIds - = [lazyId] + = [lazyId, dollarId] ++ errorIds -- Defined in MkCore ++ ghcPrimIds @@ -1040,20 +1040,32 @@ another gun with which to shoot yourself in the foot. \begin{code} lazyIdName, unsafeCoerceName, nullAddrName, seqName, realWorldName, voidPrimIdName, coercionTokenName, - magicDictName, coerceName, proxyName :: Name -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 -voidPrimIdName = mkWiredInIdName gHC_PRIM (fsLit "void#") voidPrimIdKey voidPrimId -lazyIdName = mkWiredInIdName gHC_MAGIC (fsLit "lazy") lazyIdKey lazyId -coercionTokenName = mkWiredInIdName gHC_PRIM (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId -magicDictName = mkWiredInIdName gHC_PRIM (fsLit "magicDict") magicDictKey magicDictId -coerceName = mkWiredInIdName gHC_PRIM (fsLit "coerce") coerceKey coerceId -proxyName = mkWiredInIdName gHC_PRIM (fsLit "proxy#") proxyHashKey proxyHashId + magicDictName, coerceName, proxyName, dollarName :: Name +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 +voidPrimIdName = mkWiredInIdName gHC_PRIM (fsLit "void#") voidPrimIdKey voidPrimId +lazyIdName = mkWiredInIdName gHC_MAGIC (fsLit "lazy") lazyIdKey lazyId +coercionTokenName = mkWiredInIdName gHC_PRIM (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId +magicDictName = mkWiredInIdName gHC_PRIM (fsLit "magicDict") magicDictKey magicDictId +coerceName = mkWiredInIdName gHC_PRIM (fsLit "coerce") coerceKey coerceId +proxyName = mkWiredInIdName gHC_PRIM (fsLit "proxy#") proxyHashKey proxyHashId +dollarName = mkWiredInIdName gHC_BASE (fsLit "$") dollarIdKey dollarId \end{code} \begin{code} +dollarId :: Id -- Note [dollarId magic] +dollarId = pcMiscPrelId dollarName ty + (noCafIdInfo `setUnfoldingInfo` unf) + where + fun_ty = mkFunTy alphaTy openBetaTy + ty = mkForAllTys [alphaTyVar, openBetaTyVar] $ + mkFunTy fun_ty fun_ty + unf = mkInlineUnfolding (Just 2) rhs + [f,x] = mkTemplateLocals [fun_ty, alphaTy] + rhs = mkLams [alphaTyVar, openBetaTyVar, f, x] $ + App (Var f) (Var x) ------------------------------------------------ -- proxy# :: forall a. Proxy# a @@ -1160,6 +1172,20 @@ coerceId = pcMiscPrelId coerceName ty info [(DataAlt coercibleDataCon, [eq], Cast (Var x) (CoVarCo eq))] \end{code} +Note [dollarId magic] +~~~~~~~~~~~~~~~~~~~~~ +The only reason that ($) is wired in is so that its type can be + forall (a:*, b:Open). (a->b) -> a -> b +That is, the return type can be unboxed. E.g. this is OK + foo $ True where foo :: Bool -> Int# +because ($) doesn't inspect or move the result of the call to foo. +See Trac #8739. + +There is a special typing rule for ($) in TcExpr, so the type of ($) +isn't looked at there, BUT Lint subsequently (and rightly) complains +if sees ($) applied to Int# (say), unless we give it a wired-in type +as we do here. + Note [Unsafe coerce magic] ~~~~~~~~~~~~~~~~~~~~~~~~~~ We define a *primitive* diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 3f00c6242c..0a44003244 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -250,8 +250,6 @@ basicKnownKeyNames concatName, filterName, mapName, zipName, foldrName, buildName, augmentName, appendName, - dollarName, -- The ($) apply function - -- FFI primitive types that are not wired-in. stablePtrTyConName, ptrTyConName, funPtrTyConName, int8TyConName, int16TyConName, int32TyConName, int64TyConName, @@ -851,7 +849,7 @@ groupWithName = varQual gHC_EXTS (fsLit "groupWith") groupWithIdKey fromStringName, otherwiseIdName, foldrName, buildName, augmentName, mapName, appendName, assertName, breakpointName, breakpointCondName, breakpointAutoName, - dollarName, opaqueTyConName :: Name + opaqueTyConName :: Name fromStringName = methName dATA_STRING (fsLit "fromString") fromStringClassOpKey otherwiseIdName = varQual gHC_BASE (fsLit "otherwise") otherwiseIdKey foldrName = varQual gHC_BASE (fsLit "foldr") foldrIdKey @@ -859,7 +857,6 @@ buildName = varQual gHC_BASE (fsLit "build") buildIdKey augmentName = varQual gHC_BASE (fsLit "augment") augmentIdKey mapName = varQual gHC_BASE (fsLit "map") mapIdKey appendName = varQual gHC_BASE (fsLit "++") appendIdKey -dollarName = varQual gHC_BASE (fsLit "$") dollarIdKey assertName = varQual gHC_BASE (fsLit "assert") assertIdKey breakpointName = varQual gHC_BASE (fsLit "breakpoint") breakpointIdKey breakpointCondName= varQual gHC_BASE (fsLit "breakpointCond") breakpointCondIdKey diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 409a230471..b5d7d2ea1d 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -318,24 +318,25 @@ tcExpr (OpApp arg1 op fix arg2) res_ty -- arg1_ty = arg2_ty -> op_res_ty -- And arg2_ty maybe polymorphic; that's the point - -- Make sure that the argument and result types have kind '*' + -- Make sure that the argument type has kind '*' -- Eg we do not want to allow (D# $ 4.0#) Trac #5570 -- (which gives a seg fault) -- We do this by unifying with a MetaTv; but of course -- it must allow foralls in the type it unifies with (hence PolyTv)! + -- + -- The result type can have any kind (Trac #8739), + -- so we can just use res_ty - -- ($) :: forall ab. (a->b) -> a -> b + -- ($) :: forall (a:*) (b:Open). (a->b) -> a -> b ; a_ty <- newPolyFlexiTyVarTy - ; b_ty <- newPolyFlexiTyVarTy ; arg2' <- tcArg op (arg2, arg2_ty, 2) - ; co_res <- unifyType b_ty res_ty -- b ~ res - ; co_a <- unifyType arg2_ty a_ty -- arg2 ~ a - ; co_b <- unifyType op_res_ty b_ty -- op_res ~ b + ; co_a <- unifyType arg2_ty a_ty -- arg2 ~ a + ; co_b <- unifyType op_res_ty res_ty -- op_res ~ res ; op_id <- tcLookupId op_name - ; let op' = L loc (HsWrap (mkWpTyApps [a_ty, b_ty]) (HsVar op_id)) - ; return $ mkHsWrapCo (co_res) $ + ; let op' = L loc (HsWrap (mkWpTyApps [a_ty, res_ty]) (HsVar op_id)) + ; return $ OpApp (mkLHsWrapCo (mkTcFunCo Nominal co_a co_b) $ mkLHsWrapCo co_arg1 arg1') op' fix |