Commit dca44adb authored by Richard Eisenberg's avatar Richard Eisenberg

Fix #12709 by not building bad applications

In an effort to report multiple levity polymorphism errors all at
once, the desugarer does not fail when encountering bad levity
polymorphism. But we must be careful not to build the bad applications,
lest they try to satisfy the let/app invariant and call
isUnliftedType on a levity polymorphic type. This protects calls
to mkCoreAppDs appropriately.

test case: typecheck/should_fail/T12709
parent 4dc99300
......@@ -21,7 +21,7 @@ module MkCore (
-- * Constructing small tuples
mkCoreVarTup, mkCoreVarTupTy, mkCoreTup, mkCoreUbxTup,
mkCoreTupBoxity,
mkCoreTupBoxity, unitExpr,
-- * Constructing big tuples
mkBigCoreVarTup, mkBigCoreVarTup1,
......@@ -396,6 +396,9 @@ mkBigCoreTup = mkChunkified mkCoreTup
mkBigCoreTupTy :: [Type] -> Type
mkBigCoreTupTy = mkChunkified mkBoxedTupleTy
-- | The unit expression
unitExpr :: CoreExpr
unitExpr = Var unitDataConId
{-
************************************************************************
......
......@@ -1135,8 +1135,10 @@ dsHsWrapper (WpFun c1 c2 t1 doc)
; w2 <- dsHsWrapper c2
; let app f a = mkCoreAppDs (text "dsHsWrapper") f a
arg = w1 (Var x)
; dsNoLevPolyExpr arg doc
; return (\e -> (Lam x (w2 (app e arg)))) }
; (_, ok) <- askNoErrsDs $ dsNoLevPolyExpr arg doc
; if ok
then return (\e -> (Lam x (w2 (app e arg))))
else return id } -- this return is irrelevant
dsHsWrapper (WpCast co) = ASSERT(coercionRole co == Representational)
return $ \e -> mkCastDs e co
dsHsWrapper (WpEvApp tm) = do { core_tm <- dsEvTerm tm
......
......@@ -292,7 +292,9 @@ dsExpr (HsLamCase matches)
; return $ Lam discrim_var matching_code }
dsExpr e@(HsApp fun arg)
= mkCoreAppDs (text "HsApp" <+> ppr e) <$> dsLExpr fun <*> dsLExprNoLP arg
= do { fun' <- dsLExpr fun
; dsWhenNoErrs (dsLExprNoLP arg)
(\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') }
dsExpr (HsAppTypeOut e _)
-- ignore type arguments here; they're in the wrappers instead at this point
......@@ -340,10 +342,14 @@ will sort it out.
dsExpr e@(OpApp e1 op _ e2)
= -- for the type of y, we need the type of op's 2nd argument
mkCoreAppsDs (text "opapp" <+> ppr e) <$> dsLExpr op <*> mapM dsLExprNoLP [e1, e2]
do { op' <- dsLExpr op
; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2])
(\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') }
dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e)
= mkCoreAppDs (text "sectionl" <+> ppr expr) <$> dsLExpr op <*> dsLExprNoLP expr
= do { op' <- dsLExpr op
; dsWhenNoErrs (dsLExprNoLP expr)
(\expr' -> mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr') }
-- dsLExpr (SectionR op expr) -- \ x -> op x expr
dsExpr e@(SectionR op expr) = do
......@@ -352,10 +358,10 @@ dsExpr e@(SectionR op expr) = do
let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
-- See comment with SectionL
y_core <- dsLExpr expr
x_id <- newSysLocalDsNoLP x_ty
y_id <- newSysLocalDsNoLP y_ty
return (bindNonRec y_id y_core $
Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e) core_op [Var x_id, Var y_id]))
dsWhenNoErrs (mapM newSysLocalDsNoLP [x_ty, y_ty])
(\[x_id, y_id] -> bindNonRec y_id y_core $
Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e)
core_op [Var x_id, Var y_id]))
dsExpr (ExplicitTuple tup_args boxity)
= do { let go (lam_vars, args) (L _ (Missing ty))
......@@ -765,8 +771,8 @@ dsSyntaxExpr (SyntaxExpr { syn_expr = expr
; core_arg_wraps <- mapM dsHsWrapper arg_wraps
; core_res_wrap <- dsHsWrapper res_wrap
; let wrapped_args = zipWith ($) core_arg_wraps arg_exprs
; zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ]
; return (core_res_wrap (mkApps fun wrapped_args)) }
; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ])
(\_ -> core_res_wrap (mkApps fun wrapped_args)) }
where
mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr)
......
......@@ -49,13 +49,13 @@ module DsMonad (
CanItFail(..), orFail,
-- Levity polymorphism
dsNoLevPoly, dsNoLevPolyExpr
dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs
) where
import TcRnMonad
import FamInstEnv
import CoreSyn
import MkCore ( mkCoreTup )
import MkCore ( unitExpr )
import CoreUtils ( exprType, isExprLevPoly )
import HsSyn
import TcIface
......@@ -444,7 +444,7 @@ errDs err
errDsCoreExpr :: SDoc -> DsM CoreExpr
errDsCoreExpr err
= do { errDs err
; return $ mkCoreTup [] }
; return unitExpr }
failWithDs :: SDoc -> DsM a
failWithDs err
......@@ -570,6 +570,20 @@ dsNoLevPolyExpr e doc
| isExprLevPoly e = errDs (formatLevPolyErr (exprType e) $$ doc)
| otherwise = return ()
-- | Runs the thing_inside. If there are no errors, then returns the expr
-- given. Otherwise, returns unitExpr. This is useful for doing a bunch
-- of levity polymorphism checks and then avoiding making a core App.
-- (If we make a core App on a levity polymorphic argument, detecting how
-- to handle the let/app invariant might call isUnliftedType, which panics
-- on a levity polymorphic type.)
-- See #12709 for an example of why this machinery is necessary.
dsWhenNoErrs :: DsM a -> (a -> CoreExpr) -> DsM CoreExpr
dsWhenNoErrs thing_inside mk_expr
= do { (result, no_errs) <- askNoErrsDs thing_inside
; return $ if no_errs
then mk_expr result
else unitExpr }
--------------------------------------------------------------------------
-- Data Parallel Haskell
--------------------------------------------------------------------------
......
......@@ -540,6 +540,7 @@ into
which stupidly tries to bind the datacon 'True'.
-}
-- NB: Make sure the argument is not levity polymorphic
mkCoreAppDs :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreAppDs _ (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
| f `hasKey` seqIdKey -- Note [Desugaring seq (1), (2)]
......@@ -552,6 +553,7 @@ mkCoreAppDs _ (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
mkCoreAppDs s fun arg = mkCoreApp s fun arg -- The rest is done in MkCore
-- NB: No argument can be levity polymorphic
mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreAppsDs s fun args = foldl (mkCoreAppDs s) fun args
......
{-# Language MagicHash, PolyKinds, ViewPatterns, TypeInType, RebindableSyntax, NoImplicitPrelude #-}
module T12709 where
import GHC.Types
import Prelude hiding (Num (..))
import qualified Prelude as P
import GHC.Prim
data BoxUnbox = BUB Int Int#
class Num (a :: TYPE rep) where
(+) :: a -> a -> a
fromInteger :: Integer -> a
instance Num Int where
(+) = (P.+)
fromInteger = P.fromInteger
instance Num Int# where
(+) = (+#)
fromInteger (fromInteger -> I# n) = n
a :: BoxUnbox
a = let u :: Num (a :: TYPE rep) => a
u = 1 + 2 + 3 + 4
in
BUB u u
T12709.hs:27:13: error:
A levity-polymorphic type is not allowed here:
Type: a
Kind: TYPE rep
In the type of expression: 1
T12709.hs:27:17: error:
A levity-polymorphic type is not allowed here:
Type: a
Kind: TYPE rep
In the type of expression: 2
T12709.hs:27:21: error:
A levity-polymorphic type is not allowed here:
Type: a
Kind: TYPE rep
In the type of expression: 3
T12709.hs:27:25: error:
A levity-polymorphic type is not allowed here:
Type: a
Kind: TYPE rep
In the type of expression: 4
......@@ -429,3 +429,4 @@ test('T13105', normal, compile_fail, [''])
test('LevPolyBounded', normal, compile_fail, [''])
test('T13292', normal, multimod_compile, ['T13292', '-v0 -fdefer-type-errors'])
test('T13300', normal, compile_fail, [''])
test('T12709', normal, compile_fail, [''])
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