Commit 5dd1cbbf authored by Simon Peyton Jones's avatar Simon Peyton Jones

Allow ($) to return an unlifted type (Trac #8739)

Since ($) simply returns its result, via a tail call, it can
perfectly well have an unlifted result type; e.g.
    foo $ True    where  foo :: Bool -> Int#
should be perfectly fine.

This used to work in GHC 7.2, but caused a Lint failure.  This patch
makes it work again (which involved removing code in TcExpr), but fixing
the Lint failure meant I had to make ($) into a wired-in Id.  Which
is not hard to do (in MkId).
parent 47f473b0
......@@ -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*
......
......@@ -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
......
......@@ -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
......
{-# LANGUAGE MagicHash #-}
module Main where
import GHC.Exts
go :: () -> Int#
go () = 0#
main = print (I# (go $ ()))
......@@ -2,7 +2,7 @@
T7857.hs:8:11:
Could not deduce (PrintfType s0) arising from a use of ‛printf’
from the context (PrintfArg t)
bound by the inferred type of g :: PrintfArg t => t -> s
bound by the inferred type of g :: PrintfArg t => t -> b
at T7857.hs:8:1-21
The type variable ‛s0’ is ambiguous
Note: there are several potential instances:
......
{-# LANGUAGE MagicHash #-}
module Main where
import GHC.Exts
go :: () -> Int#
go () = 0#
main = print (lazy (I# (go $ ())))
......@@ -114,3 +114,4 @@ test('TcTypeNatSimpleRun', normal, compile_and_run, [''])
test('TcCoercible', when(compiler_lt('ghc', '7.7'), skip), compile_and_run, [''])
test('T8119', normal, ghci_script, ['T8119.script'])
test('T8492', normal, compile_and_run, [''])
test('T8739', normal, compile_and_run, [''])
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment