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).

8 files changed, 71 insertions, 25 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
diff --git a/testsuite/tests/typecheck/should_compile/T8739.hs b/testsuite/tests/typecheck/should_compile/T8739.hs
new file mode 100644
index 0000000000..3fb4df3d56
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T8739.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE MagicHash #-}
+module Main where
+import GHC.Exts
+
+go :: () -> Int#
+go () = 0#
+
+main = print (I# (go $ ()))
+
+
diff --git a/testsuite/tests/typecheck/should_fail/T7857.stderr b/testsuite/tests/typecheck/should_fail/T7857.stderr
index d360c389b0..0457093fea 100644
--- a/testsuite/tests/typecheck/should_fail/T7857.stderr
+++ b/testsuite/tests/typecheck/should_fail/T7857.stderr
@@ -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:
diff --git a/testsuite/tests/typecheck/should_run/T8739.hs b/testsuite/tests/typecheck/should_run/T8739.hs
new file mode 100644
index 0000000000..233d11d79c
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/T8739.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE MagicHash #-}
+module Main where
+import GHC.Exts
+
+go :: () -> Int#
+go () = 0#
+
+main = print (lazy (I# (go $ ())))
+
+
diff --git a/testsuite/tests/typecheck/should_run/T8739.stdout b/testsuite/tests/typecheck/should_run/T8739.stdout
new file mode 100644
index 0000000000..573541ac97
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/T8739.stdout
@@ -0,0 +1 @@
+0
diff --git a/testsuite/tests/typecheck/should_run/all.T b/testsuite/tests/typecheck/should_run/all.T
index fe87cecaef..735fa54fd5 100755
--- a/testsuite/tests/typecheck/should_run/all.T
+++ b/testsuite/tests/typecheck/should_run/all.T
@@ -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, [''])