diff options
163 files changed, 2522 insertions, 1462 deletions
diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs index 5f73843ccf..37baf2bac6 100644 --- a/compiler/basicTypes/BasicTypes.hs +++ b/compiler/basicTypes/BasicTypes.hs @@ -753,7 +753,7 @@ pprAlternative :: (a -> SDoc) -- ^ The pretty printing function to use -> SDoc -- ^ 'SDoc' where the alternative havs been pretty -- printed and finally packed into a paragraph. pprAlternative pp x alt arity = - fsep (replicate (alt - 1) vbar ++ [pp x] ++ replicate (arity - alt - 1) vbar) + fsep (replicate (alt - 1) vbar ++ [pp x] ++ replicate (arity - alt) vbar) {- ************************************************************************ diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs index 84cafa3902..bab8caf017 100644 --- a/compiler/basicTypes/Id.hs +++ b/compiler/basicTypes/Id.hs @@ -85,12 +85,13 @@ module Id ( -- ** Reading 'IdInfo' fields idArity, - idCallArity, + idCallArity, idFunRepArity, idUnfolding, realIdUnfolding, idSpecialisation, idCoreRules, idHasRules, idCafInfo, idOneShotInfo, idStateHackOneShotInfo, idOccInfo, + isNeverLevPolyId, -- ** Writing 'IdInfo' fields setIdUnfolding, @@ -125,6 +126,7 @@ import Var( Id, CoVar, DictId, import qualified Var import Type +import RepType import TysPrim import DataCon import Demand @@ -563,6 +565,9 @@ idCallArity id = callArityInfo (idInfo id) setIdCallArity :: Id -> Arity -> Id setIdCallArity id arity = modifyIdInfo (`setCallArityInfo` arity) id +idFunRepArity :: Id -> RepArity +idFunRepArity x = countFunRepArgs (idArity x) (idType x) + -- | Returns true if an application to n args would diverge isBottomingId :: Id -> Bool isBottomingId id = isBottomingSig (idStrictness id) @@ -863,3 +868,6 @@ transferPolyIdInfo old_id abstract_wrt new_id `setInlinePragInfo` old_inline_prag `setOccInfo` old_occ_info `setStrictnessInfo` new_strictness + +isNeverLevPolyId :: Id -> Bool +isNeverLevPolyId = isNeverLevPolyIdInfo . idInfo diff --git a/compiler/basicTypes/IdInfo.hs b/compiler/basicTypes/IdInfo.hs index 392c1eca5b..3c6727c8dc 100644 --- a/compiler/basicTypes/IdInfo.hs +++ b/compiler/basicTypes/IdInfo.hs @@ -8,6 +8,8 @@ Haskell. [WDP 94/11]) -} +{-# LANGUAGE CPP #-} + module IdInfo ( -- * The IdDetails type IdDetails(..), pprIdDetails, coVarDetails, isCoVarDetails, @@ -66,8 +68,14 @@ module IdInfo ( -- ** Tick-box Info TickBoxOp(..), TickBoxId, + + -- ** Levity info + LevityInfo, levityInfo, setNeverLevPoly, setLevityInfoWithType, + isNeverLevPolyIdInfo ) where +#include "HsVersions.h" + import CoreSyn import Class @@ -78,10 +86,12 @@ import BasicTypes import DataCon import TyCon import PatSyn +import Type import ForeignCall import Outputable import Module import Demand +import Util -- infixl so you can say (id `set` a `set` b) infixl 1 `setRuleInfo`, @@ -92,7 +102,9 @@ infixl 1 `setRuleInfo`, `setOccInfo`, `setCafInfo`, `setStrictnessInfo`, - `setDemandInfo` + `setDemandInfo`, + `setNeverLevPoly`, + `setLevityInfoWithType` {- ************************************************************************ @@ -127,7 +139,8 @@ data IdDetails -- or class operation of a class | PrimOpId PrimOp -- ^ The 'Id' is for a primitive operator - | FCallId ForeignCall -- ^ The 'Id' is for a foreign call + | FCallId ForeignCall -- ^ The 'Id' is for a foreign call. + -- Type will be simple: no type families, newtypes, etc | TickBoxOpId TickBoxOp -- ^ The 'Id' is for a HPC tick box (both traditional and binary) @@ -169,18 +182,18 @@ pprIdDetails :: IdDetails -> SDoc pprIdDetails VanillaId = empty pprIdDetails other = brackets (pp other) where - pp VanillaId = panic "pprIdDetails" - pp (DataConWorkId _) = text "DataCon" - pp (DataConWrapId _) = text "DataConWrapper" - pp (ClassOpId {}) = text "ClassOp" - pp (PrimOpId _) = text "PrimOp" - pp (FCallId _) = text "ForeignCall" - pp (TickBoxOpId _) = text "TickBoxOp" - pp (DFunId nt) = text "DFunId" <> ppWhen nt (text "(nt)") + pp VanillaId = panic "pprIdDetails" + pp (DataConWorkId _) = text "DataCon" + pp (DataConWrapId _) = text "DataConWrapper" + pp (ClassOpId {}) = text "ClassOp" + pp (PrimOpId _) = text "PrimOp" + pp (FCallId _) = text "ForeignCall" + pp (TickBoxOpId _) = text "TickBoxOp" + pp (DFunId nt) = text "DFunId" <> ppWhen nt (text "(nt)") pp (RecSelId { sel_naughty = is_naughty }) - = brackets $ text "RecSel" - <> ppWhen is_naughty (text "(naughty)") - pp CoVarId = text "CoVarId" + = brackets $ text "RecSel" <> + ppWhen is_naughty (text "(naughty)") + pp CoVarId = text "CoVarId" {- ************************************************************************ @@ -221,8 +234,10 @@ data IdInfo strictnessInfo :: StrictSig, -- ^ A strictness signature demandInfo :: Demand, -- ^ ID demand information - callArityInfo :: !ArityInfo -- ^ How this is called. + callArityInfo :: !ArityInfo, -- ^ How this is called. -- n <=> all calls have at least n arguments + + levityInfo :: LevityInfo -- ^ when applied, will this Id ever have a levity-polymorphic type? } -- Setters @@ -272,7 +287,8 @@ vanillaIdInfo occInfo = NoOccInfo, demandInfo = topDmd, strictnessInfo = nopSig, - callArityInfo = unknownArity + callArityInfo = unknownArity, + levityInfo = NoLevityInfo } -- | More informative 'IdInfo' we can use when we know the 'Id' has no CAF references @@ -520,3 +536,51 @@ data TickBoxOp instance Outputable TickBoxOp where ppr (TickBox mod n) = text "tick" <+> ppr (mod,n) + +{- +************************************************************************ +* * + Levity +* * +************************************************************************ + +Note [Levity info] +~~~~~~~~~~~~~~~~~~ + +Ids store whether or not they can be levity-polymorphic at any amount +of saturation. This is helpful in optimizing the levity-polymorphism check +done in the desugarer, where we can usually learn that something is not +levity-polymorphic without actually figuring out its type. See +isExprLevPoly in CoreUtils for where this info is used. Storing +this is required to prevent perf/compiler/T5631 from blowing up. + +-} + +-- See Note [Levity info] +data LevityInfo = NoLevityInfo -- always safe + | NeverLevityPolymorphic + deriving Eq + +instance Outputable LevityInfo where + ppr NoLevityInfo = text "NoLevityInfo" + ppr NeverLevityPolymorphic = text "NeverLevityPolymorphic" + +-- | Marks an IdInfo describing an Id that is never levity polymorphic (even when +-- applied). The Type is only there for checking that it's really never levity +-- polymorphic +setNeverLevPoly :: HasDebugCallStack => IdInfo -> Type -> IdInfo +setNeverLevPoly info ty + = ASSERT2( not (resultIsLevPoly ty), ppr ty ) + info { levityInfo = NeverLevityPolymorphic } + +setLevityInfoWithType :: IdInfo -> Type -> IdInfo +setLevityInfoWithType info ty + | not (resultIsLevPoly ty) + = info { levityInfo = NeverLevityPolymorphic } + | otherwise + = info + +isNeverLevPolyIdInfo :: IdInfo -> Bool +isNeverLevPolyIdInfo info + | NeverLevityPolymorphic <- levityInfo info = True + | otherwise = False diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs index df9d202fc8..417a6c7869 100644 --- a/compiler/basicTypes/MkId.hs +++ b/compiler/basicTypes/MkId.hs @@ -55,7 +55,6 @@ import TyCon import CoAxiom import Class import NameSet -import VarSet import Name import PrimOp import ForeignCall @@ -287,8 +286,9 @@ mkDictSelId name clas getNth arg_tys val_index base_info = noCafIdInfo - `setArityInfo` 1 - `setStrictnessInfo` strict_sig + `setArityInfo` 1 + `setStrictnessInfo` strict_sig + `setLevityInfoWithType` sel_ty info | new_tycon = base_info `setInlinePragInfo` alwaysInlinePragma @@ -380,10 +380,13 @@ mkDataConWorkId wkr_name data_con alg_wkr_ty = dataConRepType data_con wkr_arity = dataConRepArity data_con wkr_info = noCafIdInfo - `setArityInfo` wkr_arity - `setStrictnessInfo` wkr_sig - `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, - -- even if arity = 0 + `setArityInfo` wkr_arity + `setStrictnessInfo` wkr_sig + `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, + -- even if arity = 0 + `setLevityInfoWithType` alg_wkr_ty + -- NB: unboxed tuples have workers, so we can't use + -- setNeverLevPoly wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) (dataConCPR data_con) -- Note [Data-con worker strictness] @@ -409,8 +412,9 @@ mkDataConWorkId wkr_name data_con nt_wrap_ty = dataConUserType data_con nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo `setArityInfo` 1 -- Arity 1 - `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` newtype_unf + `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` newtype_unf + `setLevityInfoWithType` nt_wrap_ty id_arg1 = mkTemplateLocal 1 (head nt_arg_tys) newtype_unf = ASSERT2( isVanillaDataCon data_con && isSingleton nt_arg_tys, ppr data_con ) @@ -520,6 +524,7 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con -- We need to get the CAF info right here because TidyPgm -- does not tidy the IdInfo of implicit bindings (like the wrapper) -- so it not make sure that the CAF info is sane + `setNeverLevPoly` wrap_ty wrap_sig = mkClosedStrictSig wrap_arg_dmds (dataConCPR data_con) wrap_arg_dmds = map mk_dmd arg_ibangs @@ -965,10 +970,11 @@ mkPrimOpId prim_op id = mkGlobalId (PrimOpId prim_op) name ty info info = noCafIdInfo - `setRuleInfo` mkRuleInfo (maybeToList $ primOpRules name prim_op) - `setArityInfo` arity - `setStrictnessInfo` strict_sig - `setInlinePragInfo` neverInlinePragma + `setRuleInfo` mkRuleInfo (maybeToList $ primOpRules name prim_op) + `setArityInfo` arity + `setStrictnessInfo` strict_sig + `setInlinePragInfo` neverInlinePragma + `setLevityInfoWithType` res_ty -- We give PrimOps a NOINLINE pragma so that we don't -- get silly warnings from Desugar.dsRule (the inline_shadows_rule -- test) about a RULE conflicting with a possible inlining @@ -985,7 +991,7 @@ mkPrimOpId prim_op mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id mkFCallId dflags uniq fcall ty - = ASSERT( isEmptyVarSet (tyCoVarsOfType ty) ) + = ASSERT( noFreeVarsOfType ty ) -- A CCallOpId should have no free type variables; -- when doing substitutions won't substitute over it mkGlobalId (FCallId fcall) name ty info @@ -997,8 +1003,9 @@ mkFCallId dflags uniq fcall ty name = mkFCallName uniq occ_str info = noCafIdInfo - `setArityInfo` arity - `setStrictnessInfo` strict_sig + `setArityInfo` arity + `setStrictnessInfo` strict_sig + `setLevityInfoWithType` ty (bndrs, _) = tcSplitPiTys ty arity = count isAnonTyBinder bndrs @@ -1101,7 +1108,8 @@ dollarId = pcMiscPrelId dollarName ty proxyHashId :: Id proxyHashId = pcMiscPrelId proxyName ty - (noCafIdInfo `setUnfoldingInfo` evaldUnfolding) -- Note [evaldUnfoldings] + (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] + `setNeverLevPoly` ty ) where -- proxy# :: forall k (a:k). Proxy# k a bndrs = mkTemplateKiTyVars [liftedTypeKind] (\ks -> ks) @@ -1139,6 +1147,7 @@ nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info where info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` mkCompulsoryUnfolding (Lit nullAddrLit) + `setNeverLevPoly` addrPrimTy ------------------------------------------------ seqId :: Id -- See Note [seqId magic] @@ -1147,6 +1156,7 @@ seqId = pcMiscPrelId seqName ty info info = noCafIdInfo `setInlinePragInfo` inline_prag `setUnfoldingInfo` mkCompulsoryUnfolding rhs `setRuleInfo` mkRuleInfo [seq_cast_rule] + `setNeverLevPoly` ty inline_prag = alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter @@ -1188,13 +1198,13 @@ match_seq_of_cast _ _ _ _ = Nothing lazyId :: Id -- See Note [lazyId magic] lazyId = pcMiscPrelId lazyIdName ty info where - info = noCafIdInfo + info = noCafIdInfo `setNeverLevPoly` ty ty = mkSpecForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy) noinlineId :: Id -- See Note [noinlineId magic] noinlineId = pcMiscPrelId noinlineIdName ty info where - info = noCafIdInfo + info = noCafIdInfo `setNeverLevPoly` ty ty = mkSpecForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy) oneShotId :: Id -- See Note [The oneShot function] @@ -1240,6 +1250,7 @@ magicDictId :: Id -- See Note [magicDictId magic] magicDictId = pcMiscPrelId magicDictName ty info where info = noCafIdInfo `setInlinePragInfo` neverInlinePragma + `setNeverLevPoly` ty ty = mkSpecForAllTys [alphaTyVar] alphaTy -------------------------------------------------------------------------------- @@ -1249,6 +1260,7 @@ coerceId = pcMiscPrelId coerceName ty info where info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` mkCompulsoryUnfolding rhs + `setNeverLevPoly` ty eqRTy = mkTyConApp coercibleTyCon [ liftedTypeKind , alphaTy, betaTy ] eqRPrimTy = mkTyConApp eqReprPrimTyCon [ liftedTypeKind @@ -1291,7 +1303,7 @@ unboxed values (unsafeCoerce 3#). In contrast unsafeCoerce# is even more dangerous because you *can* use it on unboxed things, (unsafeCoerce# 3#) :: Int. Its type is - forall (a:OpenKind) (b:OpenKind). a -> b + forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) (a: TYPE r1) (b: TYPE r2). a -> b Note [seqId magic] ~~~~~~~~~~~~~~~~~~ @@ -1552,11 +1564,13 @@ inlined. realWorldPrimId :: Id -- :: State# RealWorld realWorldPrimId = pcMiscPrelId realWorldName realWorldStatePrimTy (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] - `setOneShotInfo` stateHackOneShot) + `setOneShotInfo` stateHackOneShot + `setNeverLevPoly` realWorldStatePrimTy) voidPrimId :: Id -- Global constant :: Void# voidPrimId = pcMiscPrelId voidPrimIdName voidPrimTy - (noCafIdInfo `setUnfoldingInfo` evaldUnfolding) -- Note [evaldUnfoldings] + (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] + `setNeverLevPoly` voidPrimTy) voidArgId :: Id -- Local lambda-bound :: Void# voidArgId = mkSysLocal (fsLit "void") voidArgIdKey voidPrimTy diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs index f0bc0968c2..3260cbab2f 100644 --- a/compiler/cmm/CmmUtils.hs +++ b/compiler/cmm/CmmUtils.hs @@ -11,7 +11,7 @@ module CmmUtils( -- CmmType primRepCmmType, slotCmmType, slotForeignHint, - typeCmmType, typeForeignHint, + typeCmmType, typeForeignHint, primRepForeignHint, -- CmmLit zeroCLit, mkIntCLit, @@ -65,7 +65,7 @@ module CmmUtils( #include "HsVersions.h" import TyCon ( PrimRep(..), PrimElemRep(..) ) -import RepType ( UnaryType, SlotTy (..), typePrimRep ) +import RepType ( UnaryType, SlotTy (..), typePrimRep1 ) import SMRep import Cmm @@ -90,7 +90,8 @@ import Hoopl primRepCmmType :: DynFlags -> PrimRep -> CmmType primRepCmmType _ VoidRep = panic "primRepCmmType:VoidRep" -primRepCmmType dflags PtrRep = gcWord dflags +primRepCmmType dflags LiftedRep = gcWord dflags +primRepCmmType dflags UnliftedRep = gcWord dflags primRepCmmType dflags IntRep = bWord dflags primRepCmmType dflags WordRep = bWord dflags primRepCmmType _ Int64Rep = b64 @@ -120,11 +121,12 @@ primElemRepCmmType FloatElemRep = f32 primElemRepCmmType DoubleElemRep = f64 typeCmmType :: DynFlags -> UnaryType -> CmmType -typeCmmType dflags ty = primRepCmmType dflags (typePrimRep ty) +typeCmmType dflags ty = primRepCmmType dflags (typePrimRep1 ty) primRepForeignHint :: PrimRep -> ForeignHint primRepForeignHint VoidRep = panic "primRepForeignHint:VoidRep" -primRepForeignHint PtrRep = AddrHint +primRepForeignHint LiftedRep = AddrHint +primRepForeignHint UnliftedRep = AddrHint primRepForeignHint IntRep = SignedHint primRepForeignHint WordRep = NoHint primRepForeignHint Int64Rep = SignedHint @@ -142,7 +144,7 @@ slotForeignHint FloatSlot = NoHint slotForeignHint DoubleSlot = NoHint typeForeignHint :: UnaryType -> ForeignHint -typeForeignHint = primRepForeignHint . typePrimRep +typeForeignHint = primRepForeignHint . typePrimRep1 --------------------------------------------------- -- diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index aac556d43f..bb82da265e 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -232,10 +232,10 @@ cgDataCon data_con -- We're generating info tables, so we don't know and care about -- what the actual arguments are. Using () here as the place holder. arg_reps :: [NonVoid PrimRep] - arg_reps = [ NonVoid (typePrimRep rep_ty) + arg_reps = [ NonVoid rep_ty | ty <- dataConRepArgTys data_con - , rep_ty <- repTypeArgs ty - , not (isVoidTy rep_ty)] + , rep_ty <- typePrimRep ty + , not (isVoidRep rep_ty) ] ; emitClosureAndInfoTable dyn_info_tbl NativeDirectCall [] $ -- NB: the closure pointer is assumed *untagged* on diff --git a/compiler/codeGen/StgCmmArgRep.hs b/compiler/codeGen/StgCmmArgRep.hs index 9821b0a267..969e14f79e 100644 --- a/compiler/codeGen/StgCmmArgRep.hs +++ b/compiler/codeGen/StgCmmArgRep.hs @@ -64,7 +64,8 @@ argRepString V64 = "V64" toArgRep :: PrimRep -> ArgRep toArgRep VoidRep = V -toArgRep PtrRep = P +toArgRep LiftedRep = P +toArgRep UnliftedRep = P toArgRep IntRep = N toArgRep WordRep = N toArgRep AddrRep = N diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index 7b9813a5e3..3cc0af0669 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -163,8 +163,8 @@ assertNonVoidStgArgs args = ASSERT(not (any (isVoidTy . stgArgType) args)) -- Why are these here? idPrimRep :: Id -> PrimRep -idPrimRep id = typePrimRep (idType id) - -- NB: typePrimRep fails on unboxed tuples, +idPrimRep id = typePrimRep1 (idType id) + -- NB: typePrimRep1 fails on unboxed tuples, -- but by StgCmm no Ids have unboxed tuple type addIdReps :: [NonVoid Id] -> [NonVoid (PrimRep, Id)] @@ -176,7 +176,7 @@ addArgReps = map (\arg -> let arg' = fromNonVoid arg in NonVoid (argPrimRep arg', arg')) argPrimRep :: StgArg -> PrimRep -argPrimRep arg = typePrimRep (stgArgType arg) +argPrimRep arg = typePrimRep1 (stgArgType arg) ----------------------------------------------------------------------------- @@ -292,8 +292,8 @@ might_be_a_function :: Type -> Bool -- Return False only if we are *sure* it's a data type -- Look through newtypes etc as much as poss might_be_a_function ty - | UnaryRep rep <- repType ty - , Just tc <- tyConAppTyCon_maybe rep + | [LiftedRep] <- typePrimRep ty + , Just tc <- tyConAppTyCon_maybe (unwrapType ty) , isDataTyCon tc = False | otherwise diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs index 01c99ecf8c..ba093fee88 100644 --- a/compiler/codeGen/StgCmmEnv.hs +++ b/compiler/codeGen/StgCmmEnv.hs @@ -193,7 +193,4 @@ idToReg :: DynFlags -> NonVoid Id -> LocalReg -- about accidental collision idToReg dflags (NonVoid id) = LocalReg (idUnique id) - (case idPrimRep id of VoidRep -> pprPanic "idToReg" (ppr id) - _ -> primRepCmmType dflags (idPrimRep id)) - - + (primRepCmmType dflags (idPrimRep id)) diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 8282f1ec88..9e1d7fa37f 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -39,8 +39,8 @@ import ForeignCall import Id import PrimOp import TyCon -import Type -import RepType ( isVoidTy, countConRepArgs ) +import Type ( isUnliftedType ) +import RepType ( isVoidTy, countConRepArgs, primRepSlot ) import CostCentre ( CostCentreStack, currentCCS ) import Maybes import Util @@ -49,6 +49,7 @@ import Outputable import Control.Monad (unless,void) import Control.Arrow (first) +import Data.Function ( on ) import Prelude hiding ((<*>)) @@ -402,14 +403,23 @@ cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts = -- assignment suffices for unlifted types do { dflags <- getDynFlags ; unless reps_compatible $ - panic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?" + pprPanic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?" + (pp_bndr v $$ pp_bndr bndr) ; v_info <- getCgIdInfo v ; emitAssign (CmmLocal (idToReg dflags (NonVoid bndr))) (idInfoToAmode v_info) ; bindArgToReg (NonVoid bndr) ; cgAlts (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alt_type alts } where - reps_compatible = idPrimRep v == idPrimRep bndr + reps_compatible = ((==) `on` (primRepSlot . idPrimRep)) v bndr + -- Must compare SlotTys, not proper PrimReps, because with unboxed sums, + -- the types of the binders are generated from slotPrimRep and might not + -- match. Test case: + -- swap :: (# Int | Int #) -> (# Int | Int #) + -- swap (# x | #) = (# | x #) + -- swap (# | y #) = (# y | #) + + pp_bndr id = ppr id <+> dcolon <+> ppr (idType id) <+> parens (ppr (idPrimRep id)) {- Note [Dodgy unsafeCoerce 2, #3132] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index d12eaaf0b8..2e3ed39a37 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -525,16 +525,16 @@ getFCallArgs args = do { mb_cmms <- mapM get args ; return (catMaybes mb_cmms) } where - get arg | isVoidRep arg_rep + get arg | null arg_reps = return Nothing | otherwise = do { cmm <- getArgAmode (NonVoid arg) ; dflags <- getDynFlags ; return (Just (add_shim dflags arg_ty cmm, hint)) } where - arg_ty = stgArgType arg - arg_rep = typePrimRep arg_ty - hint = typeForeignHint arg_ty + arg_ty = stgArgType arg + arg_reps = typePrimRep arg_ty + hint = typeForeignHint arg_ty add_shim :: DynFlags -> Type -> CmmExpr -> CmmExpr add_shim dflags arg_ty expr @@ -549,6 +549,5 @@ add_shim dflags arg_ty expr | otherwise = expr where - UnaryRep rep_ty = repType arg_ty - tycon = tyConAppTyCon rep_ty + tycon = tyConAppTyCon (unwrapType arg_ty) -- should be a tycon app, since this is a foreign call diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index dedc114e9e..4a976e68af 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -362,11 +362,11 @@ newUnboxedTupleRegs res_ty ; sequel <- getSequel ; regs <- choose_regs dflags sequel ; ASSERT( regs `equalLength` reps ) - return (regs, map slotForeignHint reps) } + return (regs, map primRepForeignHint reps) } where - MultiRep reps = repType res_ty + reps = typePrimRep res_ty choose_regs _ (AssignTo regs _) = return regs - choose_regs dflags _ = mapM (newTemp . slotCmmType dflags) reps + choose_regs dflags _ = mapM (newTemp . primRepCmmType dflags) reps diff --git a/compiler/coreSyn/CoreArity.hs b/compiler/coreSyn/CoreArity.hs index e6b1f113eb..e5b4ebc993 100644 --- a/compiler/coreSyn/CoreArity.hs +++ b/compiler/coreSyn/CoreArity.hs @@ -987,6 +987,10 @@ mkEtaWW orig_n orig_expr in_scope orig_ty = go n subst' ty' (EtaVar tv' : eis) | Just (arg_ty, res_ty) <- splitFunTy_maybe ty + , not (isTypeLevPoly arg_ty) + -- See Note [Levity polymorphism invariants] in CoreSyn + -- See also test case typecheck/should_run/EtaExpandLevPoly + , let (subst', eta_id') = freshEtaId n subst arg_ty -- Avoid free vars of the original expression = go (n-1) subst' res_ty (EtaVar eta_id' : eis) @@ -1001,7 +1005,8 @@ mkEtaWW orig_n orig_expr in_scope orig_ty go n subst ty' (EtaCo co : eis) | otherwise -- We have an expression of arity > 0, - -- but its type isn't a function. + -- but its type isn't a function, or a binder + -- is levity-polymorphic = WARN( True, (ppr orig_n <+> ppr orig_ty) $$ ppr orig_expr ) (getTCvInScope subst, reverse eis) -- This *can* legitmately happen: @@ -1011,6 +1016,7 @@ mkEtaWW orig_n orig_expr in_scope orig_ty -- with an explicit lambda having a non-function type + -------------- -- Avoiding unnecessary substitution; use short-cutting versions diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index dd86ba5b51..f9e7f863c4 100644 --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -795,6 +795,12 @@ lintCoreArg fun_ty (Type arg_ty) lintCoreArg fun_ty arg = do { arg_ty <- lintCoreExpr arg + -- See Note [Levity polymorphism invariants] in CoreSyn + ; lintL (not (isTypeLevPoly arg_ty)) + (text "Levity-polymorphic argument:" <+> + (ppr arg <+> dcolon <+> parens (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty)))) + -- check for levity polymorphism first, because otherwise isUnliftedType panics + ; checkL (not (isUnliftedType arg_ty) || exprOkForSpeculation arg) (mkLetAppMsg arg) ; lintValApp arg fun_ty arg_ty } @@ -1028,10 +1034,9 @@ lintIdBndr top_lvl id linterF (mkNonTopExternalNameMsg id) ; (ty, k) <- lintInTy (idType id) - - -- Check for levity polymorphism - ; lintL (not (isLevityPolymorphic k)) - (text "RuntimeRep-polymorphic binder:" <+> + -- See Note [Levity polymorphism invariants] in CoreSyn + ; lintL (not (isKindLevPoly k)) + (text "Levity-polymorphic binder:" <+> (ppr id <+> dcolon <+> parens (ppr ty <+> dcolon <+> ppr k))) ; let id' = setIdType id ty @@ -1085,7 +1090,7 @@ lintType ty@(TyConApp tc tys) = lintType ty' -- Expand type synonyms, so that we do not bogusly complain -- about un-saturated type synonyms - | isUnliftedTyCon tc || isTypeSynonymTyCon tc || isTypeFamilyTyCon tc + | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc -- Also type synonyms and type families , length tys < tyConArity tc = failWithL (hang (text "Un-saturated type application") 2 (ppr ty)) @@ -1128,7 +1133,7 @@ lintKind :: OutKind -> LintM () -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] lintKind k = do { sk <- lintType k - ; unless ((isStarKind sk) || (isUnliftedTypeKind sk)) + ; unless (classifiesTypeWithValues sk) (addErrL (hang (text "Ill-kinded kind:" <+> ppr k) 2 (text "has kind:" <+> ppr sk))) } @@ -1398,15 +1403,17 @@ lintCoercion co@(UnivCo prov r ty1 ty2) 2 (vcat [ text "From:" <+> ppr ty1 , text " To:" <+> ppr ty2]) isUnBoxed :: PrimRep -> Bool - isUnBoxed PtrRep = False - isUnBoxed _ = True + isUnBoxed = not . isGcPtrRep + + -- see #9122 for discussion of these checks checkTypes t1 t2 - = case (repType t1, repType t2) of - (UnaryRep _, UnaryRep _) -> - validateCoercion (typePrimRep t1) (typePrimRep t2) - (MultiRep rep1, MultiRep rep2) -> - checkWarnL (rep1 == rep2) (report "multi values with different reps") - _ -> addWarnL (report "multi rep and unary rep") + = do { checkWarnL (reps1 `equalLength` reps2) + (report "values with different # of reps") + ; zipWithM_ validateCoercion reps1 reps2 } + where + reps1 = typePrimRep t1 + reps2 = typePrimRep t2 + validateCoercion :: PrimRep -> PrimRep -> LintM () validateCoercion rep1 rep2 = do { dflags <- getDynFlags diff --git a/compiler/coreSyn/CoreSubst.hs b/compiler/coreSyn/CoreSubst.hs index 73be490edb..d98536caec 100644 --- a/compiler/coreSyn/CoreSubst.hs +++ b/compiler/coreSyn/CoreSubst.hs @@ -502,7 +502,7 @@ substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id old_ty = idType old_id no_type_change = (isEmptyVarEnv tvs && isEmptyVarEnv cvs) || - isEmptyVarSet (tyCoVarsOfType old_ty) + noFreeVarsOfType old_ty -- new_id has the right IdInfo -- The lazy-set is because we're in a loop here, with @@ -622,7 +622,7 @@ substCo subst co = Coercion.substCo (getTCvSubst subst) co substIdType :: Subst -> Id -> Id substIdType subst@(Subst _ _ tv_env cv_env) id - | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) || isEmptyVarSet (tyCoVarsOfType old_ty) = id + | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) || noFreeVarsOfType old_ty = id | otherwise = setIdType id (substTy subst old_ty) -- The tyCoVarsOfType is cheaper than it looks -- because we cache the free tyvars of the type @@ -1058,7 +1058,12 @@ maybe_substitute subst b r , isAlwaysActive (idInlineActivation b) -- Note [Inline prag in simplOpt] , not (isStableUnfolding (idUnfolding b)) , not (isExportedId b) - , not (isUnliftedType (idType b)) || exprOkForSpeculation r + , let id_ty = idType b + -- A levity-polymorphic id? Impossible you say? + -- See Note [Levity polymorphism invariants] in CoreSyn + -- Ah, but it *is* possible in the compulsory unfolding of unsafeCoerce# + -- This check prevents the isUnliftedType check from panicking. + , isTypeLevPoly id_ty || not (isUnliftedType (idType b)) || exprOkForSpeculation r = Just (extendIdSubst subst b r) | otherwise diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs index 317a78d30d..fd0cf3ed26 100644 --- a/compiler/coreSyn/CoreSyn.hs +++ b/compiler/coreSyn/CoreSyn.hs @@ -404,6 +404,9 @@ For example \(r::RuntimeRep). \(a::TYPE r). \(x::a). e is illegal because x's type has kind (TYPE r), which has 'r' free. +See Note [Levity polymorphism checking] in DsMonad to see where these +invariants are established for user-written code. + Note [CoreSyn let goal] ~~~~~~~~~~~~~~~~~~~~~~~ * The simplifier tries to ensure that if the RHS of a let is a constructor diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs index 63733079e2..84f3a93c98 100644 --- a/compiler/coreSyn/CoreUtils.hs +++ b/compiler/coreSyn/CoreUtils.hs @@ -22,7 +22,7 @@ module CoreUtils ( filterAlts, combineIdenticalAlts, refineDefaultAlt, -- * Properties of expressions - exprType, coreAltType, coreAltsType, + exprType, coreAltType, coreAltsType, isExprLevPoly, exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsBottom, getIdFromTrivialExpr_maybe, exprIsCheap, exprIsExpandable, exprIsCheap', CheapAppFun, @@ -130,6 +130,45 @@ coreAltsType :: [CoreAlt] -> Type coreAltsType (alt:_) = coreAltType alt coreAltsType [] = panic "corAltsType" +-- | Is this expression levity polymorphic? This should be the +-- same as saying (isKindLevPoly . typeKind . exprType) but +-- much faster. +isExprLevPoly :: CoreExpr -> Bool +isExprLevPoly = go + where + go (Var _) = False -- no levity-polymorphic binders + go (Lit _) = False -- no levity-polymorphic literals + go e@(App f _) | not (go_app f) = False + | otherwise = check_type e + go (Lam _ _) = False + go (Let _ e) = go e + go e@(Case {}) = check_type e -- checking type is fast + go e@(Cast {}) = check_type e + go (Tick _ e) = go e + go e@(Type {}) = pprPanic "isExprLevPoly ty" (ppr e) + go (Coercion {}) = False -- this case can happen in SetLevels + + check_type = isTypeLevPoly . exprType -- slow approach + + -- if the function is a variable (common case), check its + -- levityInfo. This might mean we don't need to look up and compute + -- on the type. Spec of these functions: return False if there is + -- no possibility, ever, of this expression becoming levity polymorphic, + -- no matter what it's applied to; return True otherwise. + -- returning True is always safe. See also Note [Levity info] in + -- IdInfo + go_app (Var id) = not (isNeverLevPolyId id) + go_app (Lit _) = False + go_app (App f _) = go_app f + go_app (Lam _ e) = go_app e + go_app (Let _ e) = go_app e + go_app (Case _ _ ty _) = resultIsLevPoly ty + go_app (Cast _ co) = resultIsLevPoly (pSnd $ coercionKind co) + go_app (Tick _ e) = go_app e + go_app e@(Type {}) = pprPanic "isExprLevPoly app ty" (ppr e) + go_app e@(Coercion {}) = pprPanic "isExprLevPoly app co" (ppr e) + + {- Note [Type bindings] ~~~~~~~~~~~~~~~~~~~~ @@ -1841,6 +1880,7 @@ diffIdInfo env bndr1 bndr2 && occInfo info1 == occInfo info2 && demandInfo info1 == demandInfo info2 && callArityInfo info1 == callArityInfo info2 + && levityInfo info1 == levityInfo info2 = locBind "in unfolding of" bndr1 bndr2 $ diffUnfold env (unfoldingInfo info1) (unfoldingInfo info2) | otherwise diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs index f670ae31f1..882faa7f92 100644 --- a/compiler/coreSyn/MkCore.hs +++ b/compiler/coreSyn/MkCore.hs @@ -172,7 +172,7 @@ mk_val_app fun arg arg_ty res_ty -- game, mk_val_app returns an expression that does not have -- have a free wild-id. So the only thing that can go wrong -- is if you take apart this case expression, and pass a - -- fragmet of it as the fun part of a 'mk_val_app'. + -- fragment of it as the fun part of a 'mk_val_app'. ----------- mkWildEvBinder :: PredType -> EvVar @@ -757,4 +757,3 @@ Notice the runtime-representation polymorphism. This ensures that "error" can be instantiated at unboxed as well as boxed types. This is OK because it never returns, so the return type is irrelevant. -} - diff --git a/compiler/coreSyn/PprCore.hs b/compiler/coreSyn/PprCore.hs index 5394697832..152a701991 100644 --- a/compiler/coreSyn/PprCore.hs +++ b/compiler/coreSyn/PprCore.hs @@ -6,6 +6,7 @@ Printing of Core syntax -} +{-# LANGUAGE MultiWayIf #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module PprCore ( pprCoreExpr, pprParendExpr, diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 1f6effa6b9..7faf8fb8ec 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -21,6 +21,7 @@ import HsSyn import Module import Outputable import DynFlags +import ConLike import Control.Monad import SrcLoc import ErrUtils @@ -509,6 +510,8 @@ addBinTickLHsExpr boxLabel (L pos e0) addTickHsExpr :: HsExpr Id -> TM (HsExpr Id) addTickHsExpr e@(HsVar (L _ id)) = do freeVar id; return e addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar" +addTickHsExpr e@(HsConLikeOut con) + | Just id <- conLikeWrapId_maybe con = do freeVar id; return e addTickHsExpr e@(HsIPVar _) = return e addTickHsExpr e@(HsOverLit _) = return e addTickHsExpr e@(HsOverLabel _) = return e diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index 93af69ba89..f686b68947 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -25,9 +25,10 @@ import qualified HsUtils -- So WATCH OUT; check each use of split*Ty functions. -- Sigh. This is a pain. -import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsSyntaxExpr ) +import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr ) import TcType +import Type ( splitPiTy ) import TcEvidence import CoreSyn import CoreFVs @@ -38,7 +39,7 @@ import DsBinds (dsHsWrapper) import Name import Var import Id -import DataCon +import ConLike import TysWiredIn import BasicTypes import PrelNames @@ -46,7 +47,7 @@ import Outputable import Bag import VarSet import SrcLoc -import ListSetOps( assocDefault ) +import ListSetOps( assocMaybe ) import Data.List import Util import UniqDFM @@ -59,23 +60,67 @@ mkCmdEnv :: CmdSyntaxTable Id -> DsM ([CoreBind], DsCmdEnv) -- See Note [CmdSyntaxTable] in HsExpr mkCmdEnv tc_meths = do { (meth_binds, prs) <- mapAndUnzipM mk_bind tc_meths + + -- NB: Some of these lookups might fail, but that's OK if the + -- symbol is never used. That's why we use Maybe first and then + -- panic. An eager panic caused trouble in typecheck/should_compile/tc192 + ; let the_arr_id = assocMaybe prs arrAName + the_compose_id = assocMaybe prs composeAName + the_first_id = assocMaybe prs firstAName + the_app_id = assocMaybe prs appAName + the_choice_id = assocMaybe prs choiceAName + the_loop_id = assocMaybe prs loopAName + + -- used as an argument in, e.g., do_premap + ; check_lev_poly 3 the_arr_id + + -- used as an argument in, e.g., dsCmdStmt/BodyStmt + ; check_lev_poly 5 the_compose_id + + -- used as an argument in, e.g., dsCmdStmt/BodyStmt + ; check_lev_poly 4 the_first_id + + -- the result of the_app_id is used as an argument in, e.g., + -- dsCmd/HsCmdArrApp/HsHigherOrderApp + ; check_lev_poly 2 the_app_id + + -- used as an argument in, e.g., HsCmdIf + ; check_lev_poly 5 the_choice_id + + -- used as an argument in, e.g., RecStmt + ; check_lev_poly 4 the_loop_id + ; return (meth_binds, DsCmdEnv { - arr_id = Var (find_meth prs arrAName), - compose_id = Var (find_meth prs composeAName), - first_id = Var (find_meth prs firstAName), - app_id = Var (find_meth prs appAName), - choice_id = Var (find_meth prs choiceAName), - loop_id = Var (find_meth prs loopAName) + arr_id = Var (unmaybe the_arr_id arrAName), + compose_id = Var (unmaybe the_compose_id composeAName), + first_id = Var (unmaybe the_first_id firstAName), + app_id = Var (unmaybe the_app_id appAName), + choice_id = Var (unmaybe the_choice_id choiceAName), + loop_id = Var (unmaybe the_loop_id loopAName) }) } where mk_bind (std_name, expr) = do { rhs <- dsExpr expr - ; id <- newSysLocalDs (exprType rhs) + ; id <- newSysLocalDs (exprType rhs) -- no check needed; these are functions ; return (NonRec id rhs, (std_name, id)) } - find_meth prs std_name - = assocDefault (mk_panic std_name) prs std_name - mk_panic std_name = pprPanic "mkCmdEnv" (text "Not found:" <+> ppr std_name) + unmaybe Nothing name = pprPanic "mkCmdEnv" (text "Not found:" <+> ppr name) + unmaybe (Just id) _ = id + + -- returns the result type of a pi-type (that is, a forall or a function) + -- Note that this result type may be ill-scoped. + res_type :: Type -> Type + res_type ty = res_ty + where + (_, res_ty) = splitPiTy ty + + check_lev_poly :: Int -- arity + -> Maybe Id -> DsM () + check_lev_poly _ Nothing = return () + check_lev_poly arity (Just id) + = dsNoLevPoly (nTimes arity res_type (idType id)) + (text "In the result of the function" <+> quotes (ppr id)) + -- arr :: forall b c. (b -> c) -> a b c do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr @@ -320,7 +365,7 @@ dsCmd ids local_vars stack_ty res_ty let (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty - core_arrow <- dsLExpr arrow + core_arrow <- dsLExprNoLP arrow core_arg <- dsLExpr arg stack_id <- newSysLocalDs stack_ty core_make_arg <- matchEnvStack env_ids stack_id core_arg @@ -376,7 +421,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do (core_cmd, free_vars, env_ids') <- dsfixCmd ids local_vars stack_ty' res_ty cmd stack_id <- newSysLocalDs stack_ty - arg_id <- newSysLocalDs arg_ty + arg_id <- newSysLocalDsNoLP arg_ty -- push the argument expression onto the stack let stack' = mkCorePairExpr (Var arg_id) (Var stack_id) @@ -409,7 +454,7 @@ dsCmd ids local_vars stack_ty res_ty local_vars' = pat_vars `unionVarSet` local_vars (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty (core_body, free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty' res_ty body - param_ids <- mapM newSysLocalDs pat_tys + param_ids <- mapM newSysLocalDsNoLP pat_tys stack_id' <- newSysLocalDs stack_ty' -- the expression is built from the inside out, so the actions @@ -527,8 +572,8 @@ dsCmd ids local_vars stack_ty res_ty left_con <- dsLookupDataCon leftDataConName right_con <- dsLookupDataCon rightDataConName let - left_id = HsVar (noLoc (dataConWrapId left_con)) - right_id = HsVar (noLoc (dataConWrapId right_con)) + left_id = HsConLikeOut (RealDataCon left_con) + right_id = HsConLikeOut (RealDataCon right_con) left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) left_id ) e right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) right_id) e @@ -565,7 +610,7 @@ dsCmd ids local_vars stack_ty res_ty -- -- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c -dsCmd ids local_vars stack_ty res_ty (HsCmdLet (L _ binds) body) env_ids = do +dsCmd ids local_vars stack_ty res_ty (HsCmdLet lbinds@(L _ binds) body) env_ids = do let defined_vars = mkVarSet (collectLocalBinders binds) local_vars' = defined_vars `unionVarSet` local_vars @@ -573,7 +618,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet (L _ binds) body) env_ids = do (core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty res_ty body stack_id <- newSysLocalDs stack_ty -- build a new environment, plus the stack, using the let bindings - core_binds <- dsLocalBinds binds (buildEnvStack env_ids' stack_id) + core_binds <- dsLocalBinds lbinds (buildEnvStack env_ids' stack_id) -- match the old environment and stack against the input core_map <- matchEnvStack env_ids stack_id core_binds return (do_premap ids @@ -590,7 +635,10 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet (L _ binds) body) env_ids = do -- -- ---> premap (\ (env,stk) -> env) c -dsCmd ids local_vars stack_ty res_ty (HsCmdDo (L _ stmts) _) env_ids = do +dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo (L loc stmts) stmts_ty) env_ids = do + putSrcSpanDs loc $ + dsNoLevPoly stmts_ty + (text "In the do-command:" <+> ppr do_block) (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids let env_ty = mkBigCoreVarTupTy env_ids core_fst <- mkFstExpr env_ty stack_ty @@ -656,7 +704,9 @@ dsfixCmd DIdSet, -- subset of local vars that occur free [Id]) -- the same local vars as a list, fed back dsfixCmd ids local_vars stk_ty cmd_ty cmd - = trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd) + = do { putSrcSpanDs (getLoc cmd) $ dsNoLevPoly cmd_ty + (text "When desugaring the command:" <+> ppr cmd) + ; trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd) } -- Feed back the list of local variables actually used a command, -- for use as the input tuple of the generated arrow. @@ -697,7 +747,9 @@ dsCmdDo _ _ _ [] _ = panic "dsCmdDo" -- -- ---> premap (\ (xs) -> ((xs), ())) c -dsCmdDo ids local_vars res_ty [L _ (LastStmt body _ _)] env_ids = do +dsCmdDo ids local_vars res_ty [L loc (LastStmt body _ _)] env_ids = do + putSrcSpanDs loc $ dsNoLevPoly res_ty + (text "In the command:" <+> ppr body) (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids let env_ty = mkBigCoreVarTupTy env_ids env_var <- newSysLocalDs env_ty @@ -765,6 +817,7 @@ dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do out_ty = mkBigCoreVarTupTy out_ids before_c_ty = mkCorePairTy in_ty1 out_ty after_c_ty = mkCorePairTy c_ty out_ty + dsNoLevPoly c_ty empty -- I (Richard E, Dec '16) have no idea what to say here snd_fn <- mkSndExpr c_ty out_ty return (do_premap ids in_ty before_c_ty out_ty core_mux $ do_compose ids before_c_ty after_c_ty out_ty @@ -834,7 +887,7 @@ dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _ _) env_ids = do -- -- ---> arr (\ (xs) -> let binds in (xs')) >>> ss -dsCmdStmt ids local_vars out_ids (LetStmt (L _ binds)) env_ids = do +dsCmdStmt ids local_vars out_ids (LetStmt binds) env_ids = do -- build a new environment using the let bindings core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids) -- match the old environment against the input @@ -1004,6 +1057,8 @@ dsfixCmdStmts dsfixCmdStmts ids local_vars out_ids stmts = trimInput (dsCmdStmts ids local_vars out_ids stmts) + -- TODO: Add levity polymorphism check for the resulting expression. + -- But I (Richard E.) don't know enough about arrows to do so. dsCmdStmts :: DsCmdEnv -- arrow combinators diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index 833d3570b3..ae18ffdf43 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -58,7 +58,7 @@ import SrcLoc import Maybes import OrdList import Bag -import BasicTypes hiding ( TopLevel ) +import BasicTypes import DynFlags import FastString import Util @@ -75,24 +75,42 @@ import Control.Monad -- | Desugar top level binds, strict binds are treated like normal -- binds since there is no good time to force before first usage. dsTopLHsBinds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr)) -dsTopLHsBinds binds = fmap (toOL . snd) (ds_lhs_binds binds) +dsTopLHsBinds binds + -- see Note [Strict binds checks] + | not (isEmptyBag unlifted_binds) || not (isEmptyBag bang_binds) + = do { mapBagM_ (top_level_err "bindings for unlifted types") unlifted_binds + ; mapBagM_ (top_level_err "strict pattern bindings") bang_binds + ; return nilOL } --- | Desugar all other kind of bindings, Ids of strict binds are returned to --- later be forced in the binding gorup body, see Note [Desugar Strict binds] -dsLHsBinds :: LHsBinds Id - -> DsM ([Id], [(Id,CoreExpr)]) -dsLHsBinds binds = do { (force_vars, binds') <- ds_lhs_binds binds - ; return (force_vars, binds') } + | otherwise + = do { (force_vars, prs) <- dsLHsBinds binds + ; when debugIsOn $ + do { xstrict <- xoptM LangExt.Strict + ; MASSERT2( null force_vars || xstrict, ppr binds $$ ppr force_vars ) } + -- with -XStrict, even top-level vars are listed as force vars. ------------------------- + ; return (toOL prs) } + + where + unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds + bang_binds = filterBag (isBangedPatBind . unLoc) binds + + top_level_err desc (L loc bind) + = putSrcSpanDs loc $ + errDs (hang (text "Top-level" <+> text desc <+> text "aren't allowed:") + 2 (ppr bind)) -ds_lhs_binds :: LHsBinds Id -> DsM ([Id], [(Id,CoreExpr)]) -ds_lhs_binds binds - = do { ds_bs <- mapBagM dsLHsBind binds +-- | Desugar all other kind of bindings, Ids of strict binds are returned to +-- later be forced in the binding gorup body, see Note [Desugar Strict binds] +dsLHsBinds :: LHsBinds Id -> DsM ([Id], [(Id,CoreExpr)]) +dsLHsBinds binds + = do { MASSERT( allBag (not . isUnliftedHsBind . unLoc) binds ) + ; ds_bs <- mapBagM dsLHsBind binds ; return (foldBag (\(a, a') (b, b') -> (a ++ b, a' ++ b')) id ([], []) ds_bs) } +------------------------ dsLHsBind :: LHsBind Id -> DsM ([Id], [(Id,CoreExpr)]) dsLHsBind (L loc bind) = do dflags <- getDynFlags @@ -168,7 +186,7 @@ dsHsBind dflags = -- See Note [AbsBinds wrappers] in HsBinds addDictsDs (toTcTypeBag (listToBag dicts)) $ -- addDictsDs: push type constraints deeper for pattern match check - do { (_, bind_prs) <- ds_lhs_binds binds + do { (_, bind_prs) <- dsLHsBinds binds ; let core_bind = Rec bind_prs ; ds_binds <- dsTcEvBinds_s ev_binds ; core_wrap <- dsHsWrapper wrap -- Usually the identity @@ -192,7 +210,7 @@ dsHsBind dflags (AbsBinds { abs_tvs = [], abs_ev_vars = [] , abs_exports = exports , abs_ev_binds = ev_binds, abs_binds = binds }) - = do { (force_vars, bind_prs) <- ds_lhs_binds binds + = do { (force_vars, bind_prs) <- dsLHsBinds binds ; let mk_bind (ABE { abe_wrap = wrap , abe_poly = global , abe_mono = local @@ -213,7 +231,7 @@ dsHsBind dflags -- See Note [Desugaring AbsBinds] = addDictsDs (toTcTypeBag (listToBag dicts)) $ -- addDictsDs: push type constraints deeper for pattern match check - do { (local_force_vars, bind_prs) <- ds_lhs_binds binds + do { (local_force_vars, bind_prs) <- dsLHsBinds binds ; let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs | (lcl_id, rhs) <- bind_prs ] -- Monomorphic recursion possible, hence Rec @@ -590,6 +608,38 @@ tuple `t`, thus: See https://ghc.haskell.org/trac/ghc/wiki/StrictPragma for a more detailed explanation of the desugaring of strict bindings. +Note [Strict binds checks] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are several checks around properly formed strict bindings. They +all link to this Note. These checks must be here in the desugarer because +we cannot know whether or not a type is unlifted until after zonking, due +to levity polymorphism. These checks all used to be handled in the typechecker +in checkStrictBinds (before Jan '17). + +We define an "unlifted bind" to be any bind that binds an unlifted id. Note that + + x :: Char + (# True, x #) = blah + +is *not* an unlifted bind. Unlifted binds are detected by HsUtils.isUnliftedHsBind. + +Define a "banged bind" to have a top-level bang. Detected by HsPat.isBangedPatBind. +Define a "strict bind" to be either an unlifted bind or a banged bind. + +The restrictions are: + 1. Strict binds may not be top-level. Checked in dsTopLHsBinds. + + 2. Unlifted binds must also be banged. (There is no trouble to compile an unbanged + unlifted bind, but an unbanged bind looks lazy, and we don't want users to be + surprised by the strictness of an unlifted bind.) Checked in first clause + of DsExpr.ds_val_bind. + + 3. Unlifted binds may not have polymorphism (#6078). (That is, no quantified type + variables or constraints.) Checked in first clause + of DsExpr.ds_val_bind. + + 4. Unlifted binds may not be recursive. Checked in second clause of ds_val_bind. + -} ------------------------ @@ -1056,11 +1106,16 @@ dsHsWrapper (WpLet ev_binds) = do { bs <- dsTcEvBinds ev_binds dsHsWrapper (WpCompose c1 c2) = do { w1 <- dsHsWrapper c1 ; w2 <- dsHsWrapper c2 ; return (w1 . w2) } -dsHsWrapper (WpFun c1 c2 t1) = do { x <- newSysLocalDs t1 + -- See comments on WpFun in TcEvidence for an explanation of what + -- the specification of this clause is +dsHsWrapper (WpFun c1 c2 t1 doc) + = do { x <- newSysLocalDsNoLP t1 ; w1 <- dsHsWrapper c1 ; w2 <- dsHsWrapper c2 ; let app f a = mkCoreAppDs (text "dsHsWrapper") f a - ; return (\e -> Lam x (w2 (app e (w1 (Var x))))) } + arg = w1 (Var x) + ; dsNoLevPolyExpr arg doc + ; return (\e -> (Lam x (w2 (app e arg)))) } dsHsWrapper (WpCast co) = ASSERT(coercionRole co == Representational) return $ \e -> mkCastDs e co dsHsWrapper (WpEvApp tm) = do { core_tm <- dsEvTerm tm @@ -1106,6 +1161,8 @@ dsEvTerm (EvCast tm co) dsEvTerm (EvDFunApp df tys tms) = do { tms' <- mapM dsEvTerm tms ; return $ Var df `mkTyApps` tys `mkApps` tms' } + -- The use of mkApps here is OK vis-a-vis levity polymorphism because + -- the terms are always evidence variables with types of kind Constraint dsEvTerm (EvCoercion co) = return (Coercion co) dsEvTerm (EvSuperClass d n) diff --git a/compiler/deSugar/DsCCall.hs b/compiler/deSugar/DsCCall.hs index d7cba6567f..b90dd80965 100644 --- a/compiler/deSugar/DsCCall.hs +++ b/compiler/deSugar/DsCCall.hs @@ -84,6 +84,7 @@ follows: dsCCall :: CLabelString -- C routine to invoke -> [CoreExpr] -- Arguments (desugared) + -- Precondition: none have levity-polymorphic types -> Safety -- Safety of the call -> Type -- Type of the result: IO t -> DsM CoreExpr -- Result, of type ??? @@ -122,7 +123,7 @@ mkFCall dflags uniq the_fcall val_args res_ty ty = mkInvForAllTys tyvars body_ty the_fcall_id = mkFCallId dflags uniq the_fcall ty -unboxArg :: CoreExpr -- The supplied argument +unboxArg :: CoreExpr -- The supplied argument, not levity-polymorphic -> DsM (CoreExpr, -- To pass as the actual argument CoreExpr -> CoreExpr -- Wrapper to unbox the arg ) @@ -130,6 +131,8 @@ unboxArg :: CoreExpr -- The supplied argument -- (x#::Int#, \W. case x of I# x# -> W) -- where W is a CoreExpr that probably mentions x# +-- always returns a non-levity-polymorphic expression + unboxArg arg -- Primtive types: nothing to unbox | isPrimitiveType arg_ty diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index 8025c69aeb..575b510e34 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -6,9 +6,9 @@ Desugaring exporessions. -} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, MultiWayIf #-} -module DsExpr ( dsExpr, dsLExpr, dsLocalBinds +module DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds , dsValBinds, dsLit, dsSyntaxExpr ) where #include "HsVersions.h" @@ -41,6 +41,7 @@ import MkCore import DynFlags import CostCentre import Id +import MkId import Module import ConLike import DataCon @@ -65,12 +66,14 @@ import Control.Monad ************************************************************************ -} -dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr -dsLocalBinds EmptyLocalBinds body = return body -dsLocalBinds (HsValBinds binds) body = dsValBinds binds body -dsLocalBinds (HsIPBinds binds) body = dsIPBinds binds body +dsLocalBinds :: LHsLocalBinds Id -> CoreExpr -> DsM CoreExpr +dsLocalBinds (L _ EmptyLocalBinds) body = return body +dsLocalBinds (L loc (HsValBinds binds)) body = putSrcSpanDs loc $ + dsValBinds binds body +dsLocalBinds (L _ (HsIPBinds binds)) body = dsIPBinds binds body ------------------------- +-- caller sets location dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds dsValBinds (ValBindsIn {}) _ = panic "dsValBinds ValBindsIn" @@ -89,25 +92,72 @@ dsIPBinds (IPBinds ip_binds ev_binds) body return (Let (NonRec n e') body) ------------------------- +-- caller sets location ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr -- Special case for bindings which bind unlifted variables -- We need to do a case right away, rather than building -- a tuple and doing selections. -- Silently ignore INLINE and SPECIALISE pragmas... ds_val_bind (NonRecursive, hsbinds) body - | [L loc bind] <- bagToList hsbinds, + | [L loc bind] <- bagToList hsbinds -- Non-recursive, non-overloaded bindings only come in ones -- ToDo: in some bizarre case it's conceivable that there -- could be dict binds in the 'binds'. (See the notes -- below. Then pattern-match would fail. Urk.) - unliftedMatchOnly bind - = putSrcSpanDs loc (dsUnliftedBind bind body) + , isUnliftedHsBind bind + = putSrcSpanDs loc $ + -- see Note [Strict binds checks] in DsBinds + if is_polymorphic bind + then errDsCoreExpr (poly_bind_err bind) + -- data Ptr a = Ptr Addr# + -- f x = let p@(Ptr y) = ... in ... + -- Here the binding for 'p' is polymorphic, but does + -- not mix with an unlifted binding for 'y'. You should + -- use a bang pattern. Trac #6078. + + else do { when (looksLazyPatBind bind) $ + warnIfSetDs Opt_WarnUnbangedStrictPatterns (unlifted_must_be_bang bind) + -- Complain about a binding that looks lazy + -- e.g. let I# y = x in ... + -- Remember, in checkStrictBinds we are going to do strict + -- matching, so (for software engineering reasons) we insist + -- that the strictness is manifest on each binding + -- However, lone (unboxed) variables are ok + + + ; dsUnliftedBind bind body } + where + is_polymorphic (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }) + = not (null tvs && null evs) + is_polymorphic (AbsBindsSig { abs_tvs = tvs, abs_ev_vars = evs }) + = not (null tvs && null evs) + is_polymorphic _ = False + + unlifted_must_be_bang bind + = hang (text "Pattern bindings containing unlifted types should use" $$ + text "an outermost bang pattern:") + 2 (ppr bind) + + poly_bind_err bind + = hang (text "You can't mix polymorphic and unlifted bindings:") + 2 (ppr bind) $$ + text "Probable fix: add a type signature" + +ds_val_bind (is_rec, binds) _body + | anyBag (isUnliftedHsBind . unLoc) binds -- see Note [Strict binds checks] in DsBinds + = ASSERT( isRec is_rec ) + errDsCoreExpr $ + hang (text "Recursive bindings for unlifted types aren't allowed:") + 2 (vcat (map ppr (bagToList binds))) -- Ordinary case for bindings; none should be unlifted -ds_val_bind (_is_rec, binds) body - = do { (force_vars,prs) <- dsLHsBinds binds +ds_val_bind (is_rec, binds) body + = do { MASSERT( isRec is_rec || isSingletonBag binds ) + -- we should never produce a non-recursive list of multiple binds + + ; (force_vars,prs) <- dsLHsBinds binds ; let body' = foldr seqVar body force_vars - ; ASSERT2( not (any (isUnliftedType . idType . fst) prs), ppr _is_rec $$ ppr binds ) + ; ASSERT2( not (any (isUnliftedType . idType . fst) prs), ppr is_rec $$ ppr binds ) case prs of [] -> return body _ -> return (Let (Rec prs) body') } @@ -170,20 +220,6 @@ dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body) ----------------------- -unliftedMatchOnly :: HsBind Id -> Bool -unliftedMatchOnly (AbsBinds { abs_binds = lbinds }) - = anyBag (unliftedMatchOnly . unLoc) lbinds -unliftedMatchOnly (AbsBindsSig { abs_sig_bind = L _ bind }) - = unliftedMatchOnly bind -unliftedMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = rhs_ty }) - = isUnliftedType rhs_ty - || isUnliftedLPat lpat - || any (isUnliftedType . idType) (collectPatBinders lpat) -unliftedMatchOnly (FunBind { fun_id = L _ id }) - = isUnliftedType (idType id) -unliftedMatchOnly _ = False -- I hope! Checked immediately by caller in fact - {- ************************************************************************ * * @@ -194,7 +230,26 @@ unliftedMatchOnly _ = False -- I hope! Checked immediately by caller in fact dsLExpr :: LHsExpr Id -> DsM CoreExpr -dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e +dsLExpr (L loc e) + = putSrcSpanDs loc $ + do { core_expr <- dsExpr e + -- uncomment this check to test the hsExprType function in TcHsSyn + -- ; MASSERT2( exprType core_expr `eqType` hsExprType e + -- , ppr e <+> dcolon <+> ppr (hsExprType e) $$ + -- ppr core_expr <+> dcolon <+> ppr (exprType core_expr) ) + ; return core_expr } + +-- | Variant of 'dsLExpr' that ensures that the result is not levity +-- polymorphic. This should be used when the resulting expression will +-- be an argument to some other function. +-- See Note [Levity polymorphism checking] in DsMonad +-- See Note [Levity polymorphism invariants] in CoreSyn +dsLExprNoLP :: LHsExpr Id -> DsM CoreExpr +dsLExprNoLP (L loc e) + = putSrcSpanDs loc $ + do { e' <- dsExpr e + ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e) + ; return e' } dsExpr :: HsExpr Id -> DsM CoreExpr dsExpr (HsPar e) = dsLExpr e @@ -202,6 +257,7 @@ dsExpr (ExprWithTySigOut e _) = dsLExpr e dsExpr (HsVar (L _ var)) = return (varToCoreExpr var) -- See Note [Desugaring vars] dsExpr (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them +dsExpr (HsConLikeOut con) = return (dsConLike con) dsExpr (HsIPVar _) = panic "dsExpr: HsIPVar" dsExpr (HsOverLabel _) = panic "dsExpr: HsOverLabel" dsExpr (HsLit lit) = dsLit lit @@ -227,7 +283,7 @@ dsExpr (HsLamCase matches) ; return $ Lam discrim_var matching_code } dsExpr e@(HsApp fun arg) - = mkCoreAppDs (text "HsApp" <+> ppr e) <$> dsLExpr fun <*> dsLExpr arg + = mkCoreAppDs (text "HsApp" <+> ppr e) <$> dsLExpr fun <*> dsLExprNoLP arg dsExpr (HsAppTypeOut e _) -- ignore type arguments here; they're in the wrappers instead at this point @@ -275,10 +331,10 @@ 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 dsLExpr [e1, e2] + mkCoreAppsDs (text "opapp" <+> ppr e) <$> dsLExpr op <*> mapM dsLExprNoLP [e1, e2] dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e) - = mkCoreAppDs (text "sectionl" <+> ppr expr) <$> dsLExpr op <*> dsLExpr expr + = mkCoreAppDs (text "sectionl" <+> ppr expr) <$> dsLExpr op <*> dsLExprNoLP expr -- dsLExpr (SectionR op expr) -- \ x -> op x expr dsExpr e@(SectionR op expr) = do @@ -287,8 +343,8 @@ 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 <- newSysLocalDs x_ty - y_id <- newSysLocalDs y_ty + 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])) @@ -296,7 +352,7 @@ dsExpr (ExplicitTuple tup_args boxity) = do { let go (lam_vars, args) (L _ (Missing ty)) -- For every missing expression, we need -- another lambda in the desugaring. - = do { lam_var <- newSysLocalDs ty + = do { lam_var <- newSysLocalDsNoLP ty ; return (lam_var : lam_vars, Var lam_var : args) } go (lam_vars, args) (L _ (Present expr)) -- Expressions that are present don't generate @@ -338,7 +394,7 @@ dsExpr (HsCase discrim matches) -- Pepe: The binds are in scope in the body but NOT in the binding group -- This is to avoid silliness in breakpoints -dsExpr (HsLet (L _ binds) body) = do +dsExpr (HsLet binds body) = do body' <- dsLExpr body dsLocalBinds binds body' @@ -391,7 +447,7 @@ dsExpr (ExplicitPArr ty []) = do dsExpr (ExplicitPArr ty xs) = do singletonP <- dsDPHBuiltin singletonPVar appP <- dsDPHBuiltin appPVar - xs' <- mapM dsLExpr xs + xs' <- mapM dsLExprNoLP xs let unary fn x = mkApps (Var fn) [Type ty, x] binary fn x y = mkApps (Var fn) [Type ty, x, y] @@ -404,10 +460,10 @@ dsExpr (ArithSeq expr witness seq) ; dsSyntaxExpr fl [newArithSeq] } dsExpr (PArrSeq expr (FromTo from to)) - = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to] + = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, to] dsExpr (PArrSeq expr (FromThenTo from thn to)) - = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to] + = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn, to] dsExpr (PArrSeq _ _) = panic "DsExpr.dsExpr: Infinite parallel array!" @@ -426,7 +482,7 @@ See Note [Grand plan for static forms] in StaticPtrTable for an overview. -} dsExpr (HsStatic _ expr@(L loc _)) = do - expr_ds <- dsLExpr expr + expr_ds <- dsLExprNoLP expr let ty = exprType expr_ds makeStaticId <- dsLookupGlobalId makeStaticName @@ -478,7 +534,7 @@ dsExpr (RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds mk_arg (arg_ty, fl) = case findField (rec_flds rbinds) (flSelector fl) of (rhs:rhss) -> ASSERT( null rhss ) - dsLExpr rhs + dsLExprNoLP rhs [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl)) unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty @@ -592,10 +648,8 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields field_labels arg_ids mk_val_arg fl pat_arg_id = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id) - -- SAFE: the typechecker will complain if the synonym is - -- not bidirectional - wrap_id = expectJust "dsExpr:mk_alt" (conLikeWrapId_maybe con) - inst_con = noLoc $ HsWrap wrap (HsVar (noLoc wrap_id)) + + inst_con = noLoc $ HsWrap wrap (HsConLikeOut con) -- Reconstruct with the WrapId so that unpacking happens -- The order here is because of the order in `TcPatSyn`. wrap = mkWpEvVarApps theta_vars <.> @@ -702,7 +756,10 @@ 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)) } + where + mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr) findField :: [LHsRecField Id arg] -> Name -> [arg] findField rbinds sel @@ -774,7 +831,7 @@ dsExplicitList :: Type -> Maybe (SyntaxExpr Id) -> [LHsExpr Id] -- See Note [Desugaring explicit lists] dsExplicitList elt_ty Nothing xs = do { dflags <- getDynFlags - ; xs' <- mapM dsLExpr xs + ; xs' <- mapM dsLExprNoLP xs ; if length xs' > maxBuildLength -- Don't generate builds if the list is very long. || length xs' == 0 @@ -795,23 +852,23 @@ dsExplicitList elt_ty (Just fln) xs dsArithSeq :: PostTcExpr -> (ArithSeqInfo Id) -> DsM CoreExpr dsArithSeq expr (From from) - = App <$> dsExpr expr <*> dsLExpr from + = App <$> dsExpr expr <*> dsLExprNoLP from dsArithSeq expr (FromTo from to) = do dflags <- getDynFlags warnAboutEmptyEnumerations dflags from Nothing to expr' <- dsExpr expr - from' <- dsLExpr from - to' <- dsLExpr to + from' <- dsLExprNoLP from + to' <- dsLExprNoLP to return $ mkApps expr' [from', to'] dsArithSeq expr (FromThen from thn) - = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn] + = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn] dsArithSeq expr (FromThenTo from thn to) = do dflags <- getDynFlags warnAboutEmptyEnumerations dflags from (Just thn) to expr' <- dsExpr expr - from' <- dsLExpr from - thn' <- dsLExpr thn - to' <- dsLExpr to + from' <- dsLExprNoLP from + thn' <- dsLExprNoLP thn + to' <- dsLExprNoLP to return $ mkApps expr' [from', thn', to'] {- @@ -837,7 +894,7 @@ dsDo stmts ; rest <- goL stmts ; dsSyntaxExpr then_expr [rhs2, rest] } - go _ (LetStmt (L _ binds)) stmts + go _ (LetStmt binds) stmts = do { rest <- goL stmts ; dsLocalBinds binds rest } @@ -935,6 +992,22 @@ mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++ {- ************************************************************************ * * + Desugaring ConLikes +* * +************************************************************************ +-} + +dsConLike :: ConLike -> CoreExpr +dsConLike (RealDataCon dc) = Var (dataConWrapId dc) +dsConLike (PatSynCon ps) = case patSynBuilder ps of + Just (id, add_void) + | add_void -> mkCoreApp (text "dsConLike" <+> ppr ps) (Var id) (Var voidPrimId) + | otherwise -> Var id + _ -> pprPanic "dsConLike" (ppr ps) + +{- +************************************************************************ +* * \subsection{Errors and contexts} * * ************************************************************************ diff --git a/compiler/deSugar/DsExpr.hs-boot b/compiler/deSugar/DsExpr.hs-boot index cc8b7ea988..864df833a7 100644 --- a/compiler/deSugar/DsExpr.hs-boot +++ b/compiler/deSugar/DsExpr.hs-boot @@ -1,10 +1,10 @@ module DsExpr where -import HsSyn ( HsExpr, LHsExpr, HsLocalBinds, SyntaxExpr ) +import HsSyn ( HsExpr, LHsExpr, LHsLocalBinds, SyntaxExpr ) import Var ( Id ) import DsMonad ( DsM ) import CoreSyn ( CoreExpr ) dsExpr :: HsExpr Id -> DsM CoreExpr -dsLExpr :: LHsExpr Id -> DsM CoreExpr +dsLExpr, dsLExprNoLP :: LHsExpr Id -> DsM CoreExpr dsSyntaxExpr :: SyntaxExpr Id -> [CoreExpr] -> DsM CoreExpr -dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr +dsLocalBinds :: LHsLocalBinds Id -> CoreExpr -> DsM CoreExpr diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs index dc084ee233..9998a4d419 100644 --- a/compiler/deSugar/DsForeign.hs +++ b/compiler/deSugar/DsForeign.hs @@ -200,7 +200,7 @@ dsFCall fn_id co fcall mDeclHeader = do (tv_bndrs, rho) = tcSplitForAllTyVarBndrs ty (arg_tys, io_res_ty) = tcSplitFunTys rho - args <- newSysLocalsDs arg_tys + args <- newSysLocalsDs arg_tys -- no FFI levity-polymorphism (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args) let @@ -300,7 +300,7 @@ dsPrimCall fn_id co fcall = do (tvs, fun_ty) = tcSplitForAllTys ty (arg_tys, io_res_ty) = tcSplitFunTys fun_ty - args <- newSysLocalsDs arg_tys + args <- newSysLocalsDs arg_tys -- no FFI levity-polymorphism ccall_uniq <- newUnique dflags <- getDynFlags @@ -724,8 +724,7 @@ toCType = f False typeTyCon :: Type -> TyCon typeTyCon ty - | UnaryRep rep_ty <- repType ty - , Just (tc, _) <- tcSplitTyConApp_maybe rep_ty + | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty) = tc | otherwise = pprPanic "DsForeign.typeTyCon" (ppr ty) @@ -784,7 +783,7 @@ getPrimTyOf ty prim_ty _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty) where - UnaryRep rep_ty = repType ty + rep_ty = unwrapType ty -- represent a primitive type as a Char, for building a string that -- described the foreign function type. The types are size-dependent, @@ -793,7 +792,7 @@ primTyDescChar :: DynFlags -> Type -> Char primTyDescChar dflags ty | ty `eqType` unitTy = 'v' | otherwise - = case typePrimRep (getPrimTyOf ty) of + = case typePrimRep1 (getPrimTyOf ty) of IntRep -> signed_word WordRep -> unsigned_word Int64Rep -> 'L' diff --git a/compiler/deSugar/DsGRHSs.hs b/compiler/deSugar/DsGRHSs.hs index 0c34bc238d..0a66bd0bb8 100644 --- a/compiler/deSugar/DsGRHSs.hs +++ b/compiler/deSugar/DsGRHSs.hs @@ -57,7 +57,7 @@ dsGRHSs :: HsMatchContext Name -> [Pat Id] -- These are to build a MatchCon -> GRHSs Id (LHsExpr Id) -- Guarded RHSs -> Type -- Type of RHS -> DsM MatchResult -dsGRHSs hs_ctx _ (GRHSs grhss (L _ binds)) rhs_ty +dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty = ASSERT( notNull grhss ) do { match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss ; let match_result1 = foldr1 combineMatchResults match_results @@ -106,7 +106,7 @@ matchGuards (BodyStmt expr _ _ _ : stmts) ctx rhs rhs_ty = do pred_expr <- dsLExpr expr return (mkGuardedMatchResult pred_expr match_result) -matchGuards (LetStmt (L _ binds) : stmts) ctx rhs rhs_ty = do +matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty = do match_result <- matchGuards stmts ctx rhs rhs_ty return (adjustMatchResultDs (dsLocalBinds binds) match_result) -- NB the dsLet occurs inside the match_result @@ -138,6 +138,7 @@ isTrueLHsExpr (L _ (HsVar (L _ v))) | v `hasKey` otherwiseIdKey || v `hasKey` getUnique trueDataConId = Just return -- trueDataConId doesn't have the same unique as trueDataCon +isTrueLHsExpr (L _ (HsConLikeOut con)) | con `hasKey` getUnique trueDataCon = Just return isTrueLHsExpr (L _ (HsTick tickish e)) | Just ticks <- isTrueLHsExpr e = Just (\x -> do wrapped <- ticks x diff --git a/compiler/deSugar/DsListComp.hs b/compiler/deSugar/DsListComp.hs index 45320ccd5d..2bb303ec98 100644 --- a/compiler/deSugar/DsListComp.hs +++ b/compiler/deSugar/DsListComp.hs @@ -12,7 +12,7 @@ module DsListComp ( dsListComp, dsPArrComp, dsMonadComp ) where #include "HsVersions.h" -import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsSyntaxExpr ) +import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr ) import HsSyn import TcHsSyn @@ -81,10 +81,10 @@ dsListComp lquals res_ty = do dsInnerListComp :: (ParStmtBlock Id Id) -> DsM (CoreExpr, Type) dsInnerListComp (ParStmtBlock stmts bndrs _) = do { let bndrs_tuple_type = mkBigCoreVarTupTy bndrs + list_ty = mkListTy bndrs_tuple_type -- really use original bndrs below! - ; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) - (mkListTy bndrs_tuple_type) + ; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty ; return (expr, bndrs_tuple_type) } @@ -135,6 +135,9 @@ dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderM , Var unzip_fn' , inner_list_expr' ] + dsNoLevPoly (tcFunResultTyN (length usingArgs') (exprType usingExpr')) + (text "In the result of a" <+> quotes (text "using") <+> text "function:" <+> ppr using) + -- Build a pattern that ensures the consumer binds into the NEW binders, -- which hold lists rather than single values let pat = mkBigLHsVarPatTupId to_bndrs -- NB: no '! @@ -225,7 +228,7 @@ deListComp (BodyStmt guard _ _ _ : quals) list = do -- rule B above return (mkIfThenElse core_guard core_rest list) -- [e | let B, qs] = let B in [e | qs] -deListComp (LetStmt (L _ binds) : quals) list = do +deListComp (LetStmt binds : quals) list = do core_rest <- deListComp quals list dsLocalBinds binds core_rest @@ -234,7 +237,7 @@ deListComp (stmt@(TransStmt {}) : quals) list = do deBindComp pat inner_list_expr quals list deListComp (BindStmt pat list1 _ _ _ : quals) core_list2 = do -- rule A' above - core_list1 <- dsLExpr list1 + core_list1 <- dsLExprNoLP list1 deBindComp pat core_list1 quals core_list2 deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list @@ -272,6 +275,8 @@ deBindComp pat core_list1 quals core_list2 = do let res_ty = exprType core_list2 h_ty = u1_ty `mkFunTy` res_ty + -- no levity polymorphism here, as list comprehensions don't work + -- with RebindableSyntax. NB: These are *not* monad comps. [h, u1, u2, u3] <- newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty] -- the "fail" value ... @@ -320,7 +325,7 @@ dfListComp _ _ [] = panic "dfListComp" dfListComp c_id n_id (LastStmt body _ _ : quals) = ASSERT( null quals ) - do { core_body <- dsLExpr body + do { core_body <- dsLExprNoLP body ; return (mkApps (Var c_id) [core_body, Var n_id]) } -- Non-last: must be a guard @@ -329,7 +334,7 @@ dfListComp c_id n_id (BodyStmt guard _ _ _ : quals) = do core_rest <- dfListComp c_id n_id quals return (mkIfThenElse core_guard core_rest (Var n_id)) -dfListComp c_id n_id (LetStmt (L _ binds) : quals) = do +dfListComp c_id n_id (LetStmt binds : quals) = do -- new in 1.3, local bindings core_rest <- dfListComp c_id n_id quals dsLocalBinds binds core_rest @@ -361,7 +366,8 @@ dfBindComp c_id n_id (pat, core_list1) quals = do let b_ty = idType n_id -- create some new local id's - [b, x] <- newSysLocalsDs [b_ty, x_ty] + b <- newSysLocalDs b_ty + x <- newSysLocalDs x_ty -- build rest of the comprehesion core_rest <- dfListComp c_id b quals @@ -489,7 +495,7 @@ dsPArrComp (ParStmt qss _ _ _ : quals) = dePArrParComp qss quals -- dsPArrComp (BindStmt p e _ _ _ : qs) = do filterP <- dsDPHBuiltin filterPVar - ce <- dsLExpr e + ce <- dsLExprNoLP e let ety'ce = parrElemType ce false = Var falseDataConId true = Var trueDataConId @@ -571,12 +577,12 @@ dePArrComp (BindStmt p e _ _ _ : qs) pa cea = do -- where -- {x_1, ..., x_n} = DV (ds) -- Defined Variables -- -dePArrComp (LetStmt (L _ ds) : qs) pa cea = do +dePArrComp (LetStmt lds@(L _ ds) : qs) pa cea = do mapP <- dsDPHBuiltin mapPVar let xs = collectLocalBinders ds ty'cea = parrElemType cea v <- newSysLocalDs ty'cea - clet <- dsLocalBinds ds (mkCoreTup (map Var xs)) + clet <- dsLocalBinds lds (mkCoreTup (map Var xs)) let'v <- newSysLocalDs (exprType clet) let projBody = mkCoreLet (NonRec let'v clet) $ mkCoreTup [Var v, Var let'v] @@ -632,7 +638,7 @@ dePArrParComp qss quals = do -- generate Core corresponding to `\p -> e' -- -deLambda :: Type -- type of the argument +deLambda :: Type -- type of the argument (not levity-polymorphic) -> LPat Id -- argument pattern -> LHsExpr Id -- body -> DsM (CoreExpr, Type) @@ -641,7 +647,7 @@ deLambda ty p e = -- generate Core for a lambda pattern match, where the body is already in Core -- -mkLambda :: Type -- type of the argument +mkLambda :: Type -- type of the argument (not levity-polymorphic) -> LPat Id -- argument pattern -> CoreExpr -- desugared body -> DsM (CoreExpr, Type) @@ -682,7 +688,7 @@ dsMcStmt (LastStmt body _ ret_op) stmts ; dsSyntaxExpr ret_op [body'] } -- [ .. | let binds, stmts ] -dsMcStmt (LetStmt (L _ binds)) stmts +dsMcStmt (LetStmt binds) stmts = do { rest <- dsMcStmts stmts ; dsLocalBinds binds rest } @@ -743,7 +749,7 @@ dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs ; let tup_n_ty' = mkBigCoreVarTupTy to_bndrs ; body <- dsMcStmts stmts_rest - ; n_tup_var' <- newSysLocalDs n_tup_ty' + ; n_tup_var' <- newSysLocalDsNoLP n_tup_ty' ; tup_n_var' <- newSysLocalDs tup_n_ty' ; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys ; us <- newUniqueSupply @@ -841,6 +847,7 @@ dsInnerMonadComp :: [ExprLStmt Id] dsInnerMonadComp stmts bndrs ret_op = dsMcStmts (stmts ++ [noLoc (LastStmt (mkBigLHsVarTupId bndrs) False ret_op)]) + -- The `unzip` function for `GroupStmt` in a monad comprehensions -- -- unzip :: m (a,b,..) -> (m a,m b,..) @@ -855,7 +862,7 @@ dsInnerMonadComp stmts bndrs ret_op mkMcUnzipM :: TransForm -> HsExpr TcId -- fmap -> Id -- Of type n (a,b,c) - -> [Type] -- [a,b,c] + -> [Type] -- [a,b,c] (not levity-polymorphic) -> DsM CoreExpr -- Of type (n a, n b, n c) mkMcUnzipM ThenForm _ ys _ = return (Var ys) -- No unzipping to do diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs index d46aeaab7a..24cca5d8b2 100644 --- a/compiler/deSugar/DsMonad.hs +++ b/compiler/deSugar/DsMonad.hs @@ -12,10 +12,11 @@ module DsMonad ( DsM, mapM, mapAndUnzipM, initDs, initDsTc, initTcDsForSolver, fixDs, - foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, + foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, xoptM, Applicative(..),(<$>), - duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId, + duplicateLocalDs, newSysLocalDsNoLP, newSysLocalDs, + newSysLocalsDsNoLP, newSysLocalsDs, newUniqueId, newFailLocalDs, newPredVarDs, getSrcSpanDs, putSrcSpanDs, mkPrintUnqualifiedDs, @@ -36,20 +37,28 @@ module DsMonad ( -- Iterations for pm checking incrCheckPmIterDs, resetPmIterDs, - -- Warnings - DsWarning, warnDs, failWithDs, discardWarningsDs, + -- Warnings and errors + DsWarning, warnDs, warnIfSetDs, errDs, errDsCoreExpr, + failWithDs, failDs, discardWarningsDs, + askNoErrsDs, -- Data types DsMatchContext(..), EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper, - CanItFail(..), orFail + CanItFail(..), orFail, + + -- Levity polymorphism + dsNoLevPoly, dsNoLevPolyExpr ) where import TcRnMonad import FamInstEnv import CoreSyn +import MkCore ( mkCoreTup ) +import CoreUtils ( exprType, isExprLevPoly ) import HsSyn import TcIface +import TcMType ( checkForLevPolyX, formatLevPolyErr ) import LoadIface import Finder import PrelNames @@ -312,11 +321,51 @@ And all this mysterious stuff is so we can occasionally reach out and grab one or more names. @newLocalDs@ isn't exported---exported functions are defined with it. The difference in name-strings makes it easier to read debugging output. + +Note [Levity polymorphism checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +According to the Levity Polymorphism paper +<http://cs.brynmawr.edu/~rae/papers/2017/levity/levity.pdf>, levity +polymorphism is forbidden in precisely two places: in the type of a bound +term-level argument and in the type of an argument to a function. The paper +explains it more fully, but briefly: expressions in these contexts need to be +stored in registers, and it's hard (read, impossible) to store something +that's levity polymorphic. + +We cannot check for bad levity polymorphism conveniently in the type checker, +because we can't tell, a priori, which levity metavariables will be solved. +At one point, I (Richard) thought we could check in the zonker, but it's hard +to know where precisely are the abstracted variables and the arguments. So +we check in the desugarer, the only place where we can see the Core code and +still report respectable syntax to the user. This covers the vast majority +of cases; see calls to DsMonad.dsNoLevPoly and friends. + +Levity polymorphism is also prohibited in the types of binders, and the +desugarer checks for this in GHC-generated Ids. (The zonker handles +the user-writted ids in zonkIdBndr.) This is done in newSysLocalDsNoLP. +The newSysLocalDs variant is used in the vast majority of cases where +the binder is obviously not levity polymorphic, omitting the check. +It would be nice to ASSERT that there is no levity polymorphism here, +but we can't, because of the fixM in DsArrows. It's all OK, though: +Core Lint will catch an error here. + +However, the desugarer is the wrong place for certain checks. In particular, +the desugarer can't report a sensible error message if an HsWrapper is malformed. +After all, GHC itself produced the HsWrapper. So we store some message text +in the appropriate HsWrappers (e.g. WpFun) that we can print out in the +desugarer. + +There are a few more checks in places where Core is generated outside the +desugarer. For example, in datatype and class declarations, where levity +polymorphism is checked for during validity checking. It would be nice to +have one central place for all this, but that doesn't seem possible while +still reporting nice error messages. + -} -- Make a new Id with the same print name, but different type, and new unique newUniqueId :: Id -> Type -> DsM Id -newUniqueId id = mkSysLocalOrCoVarM (occNameFS (nameOccName (idName id))) +newUniqueId id = mk_local (occNameFS (nameOccName (idName id))) duplicateLocalDs :: Id -> DsM Id duplicateLocalDs old_local @@ -327,12 +376,26 @@ newPredVarDs :: PredType -> DsM Var newPredVarDs pred = newSysLocalDs pred -newSysLocalDs, newFailLocalDs :: Type -> DsM Id -newSysLocalDs = mkSysLocalOrCoVarM (fsLit "ds") +newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Type -> DsM Id +newSysLocalDsNoLP = mk_local (fsLit "ds") + +-- this variant should be used when the caller can be sure that the variable type +-- is not levity-polymorphic. It is necessary when the type is knot-tied because +-- of the fixM used in DsArrows. See Note [Levity polymorphism checking] +newSysLocalDs = mkSysLocalOrCoVarM (fsLit "ds") newFailLocalDs = mkSysLocalOrCoVarM (fsLit "fail") + -- the fail variable is used only in a situation where we can tell that + -- levity-polymorphism is impossible. -newSysLocalsDs :: [Type] -> DsM [Id] -newSysLocalsDs tys = mapM newSysLocalDs tys +newSysLocalsDsNoLP, newSysLocalsDs :: [Type] -> DsM [Id] +newSysLocalsDsNoLP = mapM newSysLocalDsNoLP +newSysLocalsDs = mapM newSysLocalDs + +mk_local :: FastString -> Type -> DsM Id +mk_local fs ty = do { dsNoLevPoly ty (text "When trying to create a variable of type:" <+> + ppr ty) -- could improve the msg with another + -- parameter indicating context + ; mkSysLocalOrCoVarM fs ty } {- We can also reach out and either set/grab location information from @@ -387,6 +450,7 @@ putSrcSpanDs (RealSrcSpan real_span) thing_inside = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside -- | Emit a warning for the current source location +-- NB: Warns whether or not -Wxyz is set warnDs :: WarnReason -> SDoc -> DsM () warnDs reason warn = do { env <- getGblEnv @@ -396,15 +460,50 @@ warnDs reason warn mkWarnMsg dflags loc (ds_unqual env) warn ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) } -failWithDs :: SDoc -> DsM a -failWithDs err +-- | Emit a warning only if the correct WarnReason is set in the DynFlags +warnIfSetDs :: WarningFlag -> SDoc -> DsM () +warnIfSetDs flag warn + = whenWOptM flag $ + warnDs (Reason flag) warn + +errDs :: SDoc -> DsM () +errDs err = do { env <- getGblEnv ; loc <- getSrcSpanDs ; dflags <- getDynFlags ; let msg = mkErrMsg dflags loc (ds_unqual env) err - ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) + ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) } + +-- | Issue an error, but return the expression for (), so that we can continue +-- reporting errors. +errDsCoreExpr :: SDoc -> DsM CoreExpr +errDsCoreExpr err + = do { errDs err + ; return $ mkCoreTup [] } + +failWithDs :: SDoc -> DsM a +failWithDs err + = do { errDs err ; failM } +failDs :: DsM a +failDs = failM + +-- (askNoErrsDs m) runs m +-- If m fails, (askNoErrsDs m) fails +-- If m succeeds with result r, (askNoErrsDs m) succeeds with result (r, b), +-- where b is True iff m generated no errors +-- Regardless of success or failure, any errors generated by m are propagated +-- c.f. TcRnMonad.askNoErrs +askNoErrsDs :: DsM a -> DsM (a, Bool) +askNoErrsDs m + = do { errs_var <- newMutVar emptyMessages + ; env <- getGblEnv + ; res <- setGblEnv (env { ds_msgs = errs_var }) m + ; (warns, errs) <- readMutVar errs_var + ; updMutVar (ds_msgs env) (\ (w,e) -> (w `unionBags` warns, e `unionBags` errs)) + ; return (res, isEmptyBag errs) } + mkPrintUnqualifiedDs :: DsM PrintUnqualified mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv @@ -529,3 +628,16 @@ discardWarningsDs thing_inside ; writeTcRef (ds_msgs env) old_msgs ; return result } + +-- | Fail with an error message if the type is levity polymorphic. +dsNoLevPoly :: Type -> SDoc -> DsM () +-- See Note [Levity polymorphism checking] +dsNoLevPoly ty doc = checkForLevPolyX errDs doc ty + +-- | Check an expression for levity polymorphism, failing if it is +-- levity polymorphic. +dsNoLevPolyExpr :: CoreExpr -> SDoc -> DsM () +-- See Note [Levity polymorphism checking] +dsNoLevPolyExpr e doc + | isExprLevPoly e = errDs (formatLevPolyErr (exprType e) $$ doc) + | otherwise = return () diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs index 290c172a14..0d336adbd9 100644 --- a/compiler/deSugar/DsUtils.hs +++ b/compiler/deSugar/DsUtils.hs @@ -121,7 +121,7 @@ selectMatchVar (ParPat pat) = selectMatchVar (unLoc pat) selectMatchVar (VarPat var) = return (localiseId (unLoc var)) -- Note [Localise pattern binders] selectMatchVar (AsPat var _) = return (unLoc var) -selectMatchVar other_pat = newSysLocalDs (hsPatType other_pat) +selectMatchVar other_pat = newSysLocalDsNoLP (hsPatType other_pat) -- OK, better make up one... {- @@ -736,7 +736,7 @@ mkSelectorBinds ticks pat val_expr | is_flat_prod_lpat pat' -- Special case (B) = do { let pat_ty = hsLPatType pat' - ; val_var <- newSysLocalDs pat_ty + ; val_var <- newSysLocalDsNoLP pat_ty ; let mk_bind tick bndr_var -- (mk_bind sv bv) generates bv = case sv of { pat -> bv } diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs index 672157e0d7..f5c3cf5066 100644 --- a/compiler/deSugar/Match.hs +++ b/compiler/deSugar/Match.hs @@ -444,7 +444,18 @@ tidy1 v (AsPat (L _ var) pat) -} tidy1 v (LazyPat pat) - = do { (_,sel_prs) <- mkSelectorBinds [] pat (Var v) + -- This is a convenient place to check for unlifted types under a lazy pattern. + -- Doing this check during type-checking is unsatisfactory because we may + -- not fully know the zonked types yet. We sure do here. + = do { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders pat) + ; unless (null unlifted_bndrs) $ + putSrcSpanDs (getLoc pat) $ + errDs (hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$ + text "Unlifted variables:") + 2 (vcat (map (\id -> ppr id <+> dcolon <+> ppr (idType id)) + unlifted_bndrs))) + + ; (_,sel_prs) <- mkSelectorBinds [] pat (Var v) ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] ; return (mkCoreLets sel_binds, WildPat (idType v)) } @@ -705,7 +716,7 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches ; locn <- getSrcSpanDs ; new_vars <- case matches of - [] -> mapM newSysLocalDs arg_tys + [] -> mapM newSysLocalDsNoLP arg_tys (m:_) -> selectMatchVars (map unLoc (hsLMatchPats m)) ; eqns_info <- mapM (mk_eqn_info new_vars) matches @@ -951,6 +962,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 -- we have to compare the wrappers exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e' exp (HsVar i) (HsVar i') = i == i' + exp (HsConLikeOut c) (HsConLikeOut c') = c == c' -- the instance for IPName derives using the id, so this works if the -- above does exp (HsIPVar i) (HsIPVar i') = i == i' @@ -1012,7 +1024,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 -- equating different ways of writing a coercion) wrap WpHole WpHole = True wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2' - wrap (WpFun w1 w2 _) (WpFun w1' w2' _) = wrap w1 w1' && wrap w2 w2' + wrap (WpFun w1 w2 _ _) (WpFun w1' w2' _ _) = wrap w1 w1' && wrap w2 w2' wrap (WpCast co) (WpCast co') = co `eqCoercion` co' wrap (WpEvApp et1) (WpEvApp et2) = et1 `ev_term` et2 wrap (WpTyApp t) (WpTyApp t') = eqType t t' diff --git a/compiler/deSugar/MatchCon.hs b/compiler/deSugar/MatchCon.hs index 73b6ec300b..4a7d1cd2b7 100644 --- a/compiler/deSugar/MatchCon.hs +++ b/compiler/deSugar/MatchCon.hs @@ -207,7 +207,7 @@ same_fields flds1 flds2 ----------------- selectConMatchVars :: [Type] -> ConArgPats -> DsM [Id] -selectConMatchVars arg_tys (RecCon {}) = newSysLocalsDs arg_tys +selectConMatchVars arg_tys (RecCon {}) = newSysLocalsDsNoLP arg_tys selectConMatchVars _ (PrefixCon ps) = selectMatchVars (map unLoc ps) selectConMatchVars _ (InfixCon p1 p2) = selectMatchVars [unLoc p1, unLoc p2] diff --git a/compiler/deSugar/PmExpr.hs b/compiler/deSugar/PmExpr.hs index e45984df64..e35358fba5 100644 --- a/compiler/deSugar/PmExpr.hs +++ b/compiler/deSugar/PmExpr.hs @@ -20,6 +20,7 @@ import Id import Name import NameSet import DataCon +import ConLike import TysWiredIn import Outputable import Util @@ -230,6 +231,7 @@ lhsExprToPmExpr (L _ e) = hsExprToPmExpr e hsExprToPmExpr :: HsExpr Id -> PmExpr hsExprToPmExpr (HsVar x) = PmExprVar (idName (unLoc x)) +hsExprToPmExpr (HsConLikeOut c) = PmExprVar (conLikeName c) hsExprToPmExpr (HsOverLit olit) = PmExprLit (PmOLit False olit) hsExprToPmExpr (HsLit lit) = PmExprLit (PmSLit lit) diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs index 9a5e4141f1..a4373b459f 100644 --- a/compiler/ghci/ByteCodeGen.hs +++ b/compiler/ghci/ByteCodeGen.hs @@ -321,7 +321,7 @@ collect (_, e) = go [] e where go xs e | Just e' <- bcView e = go xs e' go xs (AnnLam x (_,e)) - | repTypeArgs (idType x) `lengthExceeds` 1 + | typePrimRep (idType x) `lengthExceeds` 1 = multiValException | otherwise = go (x:xs) e @@ -551,8 +551,6 @@ schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)]) | isUnboxedTupleCon dc -- handles pairs with one void argument (e.g. state token) - , [rep_ty1] <- repTypeArgs (idType bind1) - , [rep_ty2] <- repTypeArgs (idType bind2) -- Convert -- case .... of x { (# V'd-thing, a #) -> ... } -- to @@ -561,23 +559,25 @@ schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)]) -- -- Note that it does not matter losing the void-rep thing from the -- envt (it won't be bound now) because we never look such things up. - , Just res <- case () of - _ | isVoidTy rep_ty1 && not (isVoidTy rep_ty2) + , Just res <- case (typePrimRep (idType bind1), typePrimRep (idType bind2)) of + ([], [_]) -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr) - | isVoidTy rep_ty2 && not (isVoidTy rep_ty1) + ([_], []) -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr) - | otherwise - -> Nothing + _ -> Nothing = res schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)]) | isUnboxedTupleCon dc - , repTypeArgs (idType bndr) `lengthIs` 1 -- handles unit tuples + , length (typePrimRep (idType bndr)) <= 1 -- handles unit tuples = doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr) schemeE d s p (AnnCase scrut bndr _ alt@[(DEFAULT, [], _)]) | isUnboxedTupleType (idType bndr) - , [ty] <- repTypeArgs (idType bndr) + , Just ty <- case typePrimRep (idType bndr) of + [_] -> Just (unwrapType (idType bndr)) + [] -> Just voidPrimTy + _ -> Nothing -- handles any pattern with a single non-void binder; in particular I/O -- monad returns (# RealWorld#, a #) = doCase d s p scrut (bndr `setIdType` ty) alt (Just bndr) @@ -793,7 +793,7 @@ doCase :: Word -> Sequel -> BCEnv -> Maybe Id -- Just x <=> is an unboxed tuple case with scrut binder, don't enter the result -> BcM BCInstrList doCase d s p (_,scrut) bndr alts is_unboxed_tuple - | repTypeArgs (idType bndr) `lengthExceeds` 1 + | typePrimRep (idType bndr) `lengthExceeds` 1 = multiValException | otherwise = do @@ -970,7 +970,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l pargs _ [] = return [] pargs d (a:az) - = let [arg_ty] = repTypeArgs (exprType (deAnnotate' a)) + = let arg_ty = unwrapType (exprType (deAnnotate' a)) in case tyConAppTyCon_maybe arg_ty of -- Don't push the FO; instead push the Addr# it @@ -1195,24 +1195,22 @@ maybe_getCCallReturnRep :: Type -> Maybe PrimRep maybe_getCCallReturnRep fn_ty = let (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty) - r_reps = repTypeArgs r_ty + r_reps = typePrimRepArgs r_ty blargh :: a -- Used at more than one type blargh = pprPanic "maybe_getCCallReturn: can't handle:" (pprType fn_ty) in case r_reps of - [] -> panic "empty repTypeArgs" - [ty] - | typePrimRep ty == PtrRep - -> blargh - | isVoidTy ty - -> Nothing - | otherwise - -> Just (typePrimRep ty) + [] -> panic "empty typePrimRepArgs" + [VoidRep] -> Nothing + [rep] + | isGcPtrRep rep -> blargh + | otherwise -> Just rep + -- if it was, it would be impossible to create a -- valid return value placeholder on the stack - _ -> blargh + _ -> blargh maybe_is_tagToEnum_call :: AnnExpr' Id DVarSet -> Maybe (AnnExpr' Id DVarSet, [Name]) -- Detect and extract relevant info for the tagToEnum kludge. @@ -1224,7 +1222,7 @@ maybe_is_tagToEnum_call app = Nothing where extract_constr_Names ty - | [rep_ty] <- repTypeArgs ty + | rep_ty <- unwrapType ty , Just tyc <- tyConAppTyCon_maybe rep_ty , isDataTyCon tyc = map (getName . dataConWorkId) (tyConDataCons tyc) @@ -1331,8 +1329,7 @@ pushAtom d p (AnnCase (_, a) _ _ []) -- trac #12128 = pushAtom d p a pushAtom d p (AnnVar v) - | [rep_ty] <- repTypeArgs (idType v) - , V <- typeArgRep rep_ty + | [] <- typePrimRep (idType v) = return (nilOL, 0) | isFCallId v @@ -1542,7 +1539,11 @@ bcIdArgRep :: Id -> ArgRep bcIdArgRep = toArgRep . bcIdPrimRep bcIdPrimRep :: Id -> PrimRep -bcIdPrimRep = typePrimRep . bcIdUnaryType +bcIdPrimRep id + | [rep] <- typePrimRepArgs (idType id) + = rep + | otherwise + = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id)) isFollowableArg :: ArgRep -> Bool isFollowableArg P = True @@ -1552,11 +1553,6 @@ isVoidArg :: ArgRep -> Bool isVoidArg V = True isVoidArg _ = False -bcIdUnaryType :: Id -> UnaryType -bcIdUnaryType x = case repTypeArgs (idType x) of - [rep_ty] -> rep_ty - _ -> pprPanic "bcIdUnaryType" (ppr x $$ ppr (idType x)) - -- See bug #1257 multiValException :: a multiValException = throwGhcException (ProgramError @@ -1625,12 +1621,12 @@ isVAtom _ = False atomPrimRep :: AnnExpr' Id ann -> PrimRep atomPrimRep e | Just e' <- bcView e = atomPrimRep e' atomPrimRep (AnnVar v) = bcIdPrimRep v -atomPrimRep (AnnLit l) = typePrimRep (literalType l) +atomPrimRep (AnnLit l) = typePrimRep1 (literalType l) -- Trac #12128: -- A case expresssion can be an atom because empty cases evaluate to bottom. -- See Note [Empty case alternatives] in coreSyn/CoreSyn.hs -atomPrimRep (AnnCase _ _ ty _) = ASSERT(typePrimRep ty == PtrRep) PtrRep +atomPrimRep (AnnCase _ _ ty _) = ASSERT(typePrimRep ty == [LiftedRep]) LiftedRep atomPrimRep (AnnCoercion {}) = VoidRep atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate' other)) @@ -1648,7 +1644,7 @@ mkStackOffsets original_depth szsw = map (subtract 1) (tail (scanl (+) original_depth szsw)) typeArgRep :: Type -> ArgRep -typeArgRep = toArgRep . typePrimRep +typeArgRep = toArgRep . typePrimRep1 -- ----------------------------------------------------------------------------- -- The bytecode generator's monad diff --git a/compiler/ghci/ByteCodeItbls.hs b/compiler/ghci/ByteCodeItbls.hs index 4a4a03913d..6dc89e1d9d 100644 --- a/compiler/ghci/ByteCodeItbls.hs +++ b/compiler/ghci/ByteCodeItbls.hs @@ -16,7 +16,7 @@ import HscTypes import Name ( Name, getName ) import NameEnv import DataCon ( DataCon, dataConRepArgTys, dataConIdentity ) -import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons, isVoidRep ) +import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) import RepType import StgCmmLayout ( mkVirtConstrSizes ) import StgCmmClosure ( tagForCon, NonVoid (..) ) @@ -56,9 +56,7 @@ make_constr_itbls hsc_env cons = mk_itbl dcon conNo = do let rep_args = [ NonVoid prim_rep | arg <- dataConRepArgTys dcon - , slot_ty <- repTypeSlots (repType arg) - , let prim_rep = slotPrimRep slot_ty - , not (isVoidRep prim_rep) ] + , prim_rep <- typePrimRep arg ] (tot_wds, ptr_wds) = mkVirtConstrSizes dflags rep_args diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs index 64ac1540aa..4d7f8e3ef0 100644 --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -28,7 +28,6 @@ import Var hiding ( varName ) import VarSet import UniqFM import Type -import Kind import GHC import Outputable import PprTyThing @@ -78,7 +77,7 @@ pprintClosureCommand bindThings force str = do term_ <- GHC.obtainTermFromId maxBound force id' term <- tidyTermTyVars term_ term' <- if bindThings && - False == isUnliftedTypeKind (termType term) + (not (isUnliftedType (termType term))) then bindSuspensions term else return term -- Before leaving, we compare the type obtained to see if it's more specific diff --git a/compiler/ghci/GHCi.hsc b/compiler/ghci/GHCi.hsc index 4503034971..2354908718 100644 --- a/compiler/ghci/GHCi.hsc +++ b/compiler/ghci/GHCi.hsc @@ -641,13 +641,13 @@ wormhole dflags r = wormholeRef dflags (unsafeForeignRefToRemoteRef r) -- only works when the interpreter is running in the same process as -- the compiler, so it fails when @-fexternal-interpreter@ is on. wormholeRef :: DynFlags -> RemoteRef a -> IO a -wormholeRef dflags r +wormholeRef dflags _r | gopt Opt_ExternalInterpreter dflags = throwIO (InstallationError "this operation requires -fno-external-interpreter") #ifdef GHCI | otherwise - = localRef r + = localRef _r #else | otherwise = throwIO (InstallationError diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index 815e5e6e0f..03b2f95475 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -735,7 +735,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do traceTR (text "Following a MutVar") contents_tv <- newVar liftedTypeKind contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w - ASSERT(isUnliftedTypeKind $ typeKind my_ty) return () + ASSERT(isUnliftedType my_ty) return () (mutvar_ty,_) <- instScheme $ quantifyType $ mkFunTy contents_ty (mkTyConApp tycon [world,contents_ty]) addConstraint (mkFunTy contents_tv my_ty) mutvar_ty @@ -805,9 +805,9 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 (nonPtrs clos) (ptr_i, ws, terms1) <- go ptr_i ws tys return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1) | otherwise - = case repTypeArgs ty of + = case typePrimRepArgs ty of [rep_ty] -> do - (ptr_i, ws, term0) <- go_rep ptr_i ws ty (typePrimRep rep_ty) + (ptr_i, ws, term0) <- go_rep ptr_i ws ty rep_ty (ptr_i, ws, terms1) <- go ptr_i ws tys return (ptr_i, ws, term0 : terms1) rep_tys -> do @@ -818,18 +818,18 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 (nonPtrs clos) go_unary_types ptr_i ws [] = return (ptr_i, ws, []) go_unary_types ptr_i ws (rep_ty:rep_tys) = do tv <- newVar liftedTypeKind - (ptr_i, ws, term0) <- go_rep ptr_i ws tv (typePrimRep rep_ty) + (ptr_i, ws, term0) <- go_rep ptr_i ws tv rep_ty (ptr_i, ws, terms1) <- go_unary_types ptr_i ws rep_tys return (ptr_i, ws, term0 : terms1) - go_rep ptr_i ws ty rep = case rep of - PtrRep -> do - t <- appArr (recurse ty) (ptrs clos) ptr_i - return (ptr_i + 1, ws, t) - _ -> do - dflags <- getDynFlags - let (ws0, ws1) = splitAt (primRepSizeW dflags rep) ws - return (ptr_i, ws1, Prim ty ws0) + go_rep ptr_i ws ty rep + | isGcPtrRep rep + = do t <- appArr (recurse ty) (ptrs clos) ptr_i + return (ptr_i + 1, ws, t) + | otherwise + = do dflags <- getDynFlags + let (ws0, ws1) = splitAt (primRepSizeW dflags rep) ws + return (ptr_i, ws1, Prim ty ws0) unboxedTupleTerm ty terms = Term ty (Right (tupleDataCon Unboxed (length terms))) @@ -919,17 +919,15 @@ findPtrTys i ty = findPtrTyss i elem_tys | otherwise - = -- Can't directly call repTypeArgs here -- we lose type information in - -- some cases (e.g. singleton tuples) - case repType ty of - UnaryRep rep_ty | typePrimRep rep_ty == PtrRep -> return (i + 1, [(i, ty)]) - | otherwise -> return (i, []) - MultiRep slot_tys -> - foldM (\(i, extras) rep_ty -> - if typePrimRep rep_ty == PtrRep + = case typePrimRep ty of + [rep] | isGcPtrRep rep -> return (i + 1, [(i, ty)]) + | otherwise -> return (i, []) + prim_reps -> + foldM (\(i, extras) prim_rep -> + if isGcPtrRep prim_rep then newVar liftedTypeKind >>= \tv -> return (i + 1, extras ++ [(i, tv)]) else return (i, extras)) - (i, []) (map slotTyToType slot_tys) + (i, []) prim_reps findPtrTyss :: Int -> [Type] @@ -955,7 +953,7 @@ getDataConArgTys :: DataCon -> Type -> TR [Type] -- -- I believe that con_app_ty should not have any enclosing foralls getDataConArgTys dc con_app_ty - = do { let UnaryRep rep_con_app_ty = repType con_app_ty + = do { let rep_con_app_ty = unwrapType con_app_ty ; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty $$ ppr (tcSplitTyConApp_maybe rep_con_app_ty))) ; (subst, _) <- instTyVars (univ_tvs ++ ex_tvs) @@ -1193,7 +1191,7 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs') text " in presence of newtype evidence " <> ppr new_tycon) (_, vars) <- instTyVars (tyConTyVars new_tycon) let ty' = mkTyConApp new_tycon (mkTyVarTys vars) - UnaryRep rep_ty = repType ty' + rep_ty = unwrapType ty' _ <- liftTcM (unifyType noThing ty rep_ty) -- assumes that reptype doesn't ^^^^ touch tyconApp args return ty' @@ -1235,14 +1233,13 @@ dictsView ty = ty isMonomorphic :: RttiType -> Bool isMonomorphic ty = noExistentials && noUniversals where (tvs, _, ty') = tcSplitSigmaTy ty - noExistentials = isEmptyVarSet (tyCoVarsOfType ty') + noExistentials = noFreeVarsOfType ty' noUniversals = null tvs -- Use only for RTTI types isMonomorphicOnNonPhantomArgs :: RttiType -> Bool isMonomorphicOnNonPhantomArgs ty - | UnaryRep rep_ty <- repType ty - , Just (tc, all_args) <- tcSplitTyConApp_maybe rep_ty + | Just (tc, all_args) <- tcSplitTyConApp_maybe (unwrapType ty) , phantom_vars <- tyConPhantomTyVars tc , concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args , tyv `notElem` phantom_vars] diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs index 421a358669..e04dc89559 100644 --- a/compiler/hsSyn/HsBinds.hs +++ b/compiler/hsSyn/HsBinds.hs @@ -63,6 +63,9 @@ Global bindings (where clauses) -- | Haskell Local Bindings type HsLocalBinds id = HsLocalBindsLR id id +-- | Located Haskell local bindings +type LHsLocalBinds id = Located (HsLocalBinds id) + -- | Haskell Local Bindings with separate Left and Right identifier types -- -- Bindings in a 'let' expression @@ -82,6 +85,8 @@ data HsLocalBindsLR idL idR | EmptyLocalBinds -- ^ Empty Local Bindings +type LHsLocalBindsLR idL idR = Located (HsLocalBindsLR idL idR) + deriving instance (DataId idL, DataId idR) => Data (HsLocalBindsLR idL idR) diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index f4aa88c7aa..e4d843191f 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -287,11 +287,17 @@ data HsExpr id -- Turned into HsVar by type checker, to support -- deferred type errors. + | HsConLikeOut ConLike -- ^ After typechecker only; must be different + -- HsVar for pretty printing + | HsRecFld (AmbiguousFieldOcc id) -- ^ Variable pointing to record selector + -- Not in use after typechecking | HsOverLabel FastString -- ^ Overloaded label (See Note [Overloaded labels] -- in GHC.OverloadedLabels) - | HsIPVar HsIPName -- ^ Implicit parameter + -- NB: Not in use after typechecking + + | HsIPVar HsIPName -- ^ Implicit parameter (not in use after typechecking) | HsOverLit (HsOverLit id) -- ^ Overloaded literals | HsLit HsLit -- ^ Simple (non-overloaded) literals @@ -413,7 +419,7 @@ data HsExpr id -- 'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn' -- For details on above see note [Api annotations] in ApiAnnotation - | HsLet (Located (HsLocalBinds id)) + | HsLet (LHsLocalBinds id) (LHsExpr id) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo', @@ -811,6 +817,7 @@ ppr_lexpr e = ppr_expr (unLoc e) ppr_expr :: forall id. (OutputableBndrId id) => HsExpr id -> SDoc ppr_expr (HsVar (L _ v)) = pprPrefixOcc v ppr_expr (HsUnboundVar uv)= pprPrefixOcc (unboundVarOcc uv) +ppr_expr (HsConLikeOut c) = pprPrefixOcc c ppr_expr (HsIPVar v) = ppr v ppr_expr (HsOverLabel l) = char '#' <> ppr l ppr_expr (HsLit lit) = ppr lit @@ -827,27 +834,36 @@ ppr_expr e@(HsAppType {}) = ppr_apps e [] ppr_expr e@(HsAppTypeOut {}) = ppr_apps e [] ppr_expr (OpApp e1 op _ e2) - = case unLoc op of - HsVar (L _ v) -> pp_infixly v - HsRecFld f -> pp_infixly f - HsUnboundVar h@TrueExprHole{} -> pp_infixly (unboundVarOcc h) - _ -> pp_prefixly + | Just pp_op <- should_print_infix (unLoc op) + = pp_infixly pp_op + | otherwise + = pp_prefixly + where + should_print_infix (HsVar (L _ v)) = Just (pprInfixOcc v) + should_print_infix (HsConLikeOut c)= Just (pprInfixOcc (conLikeName c)) + should_print_infix (HsRecFld f) = Just (pprInfixOcc f) + should_print_infix (HsUnboundVar h@TrueExprHole{}) + = Just (pprInfixOcc (unboundVarOcc h)) + should_print_infix (HsWrap _ e) = should_print_infix e + should_print_infix _ = Nothing + pp_e1 = pprDebugParendExpr e1 -- In debug mode, add parens pp_e2 = pprDebugParendExpr e2 -- to make precedence clear pp_prefixly = hang (ppr op) 2 (sep [pp_e1, pp_e2]) - pp_infixly v - = hang pp_e1 2 (sep [pprInfixOcc v, nest 2 pp_e2]) + pp_infixly pp_op + = hang pp_e1 2 (sep [pp_op, nest 2 pp_e2]) ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e ppr_expr (SectionL expr op) = case unLoc op of - HsVar (L _ v) -> pp_infixly v - _ -> pp_prefixly + HsVar (L _ v) -> pp_infixly v + HsConLikeOut c -> pp_infixly (conLikeName c) + _ -> pp_prefixly where pp_expr = pprDebugParendExpr expr @@ -857,8 +873,9 @@ ppr_expr (SectionL expr op) ppr_expr (SectionR op expr) = case unLoc op of - HsVar (L _ v) -> pp_infixly v - _ -> pp_prefixly + HsVar (L _ v) -> pp_infixly v + HsConLikeOut c -> pp_infixly (conLikeName c) + _ -> pp_prefixly where pp_expr = pprDebugParendExpr expr @@ -1004,6 +1021,8 @@ ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False) ppr_expr (HsArrForm (L _ (HsVar (L _ v))) (Just _) [arg1, arg2]) = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]] +ppr_expr (HsArrForm (L _ (HsConLikeOut c)) (Just _) [arg1, arg2]) + = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc (conLikeName c), pprCmdArg (unLoc arg2)]] ppr_expr (HsArrForm op _ args) = hang (text "(|" <+> ppr_lexpr op) 4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)") @@ -1070,6 +1089,7 @@ hsExprNeedsParens (HsLit {}) = False hsExprNeedsParens (HsOverLit {}) = False hsExprNeedsParens (HsVar {}) = False hsExprNeedsParens (HsUnboundVar {}) = False +hsExprNeedsParens (HsConLikeOut {}) = False hsExprNeedsParens (HsIPVar {}) = False hsExprNeedsParens (HsOverLabel {}) = False hsExprNeedsParens (ExplicitTuple {}) = False @@ -1085,12 +1105,14 @@ hsExprNeedsParens (HsRecFld{}) = False hsExprNeedsParens (RecordCon{}) = False hsExprNeedsParens (HsSpliceE{}) = False hsExprNeedsParens (RecordUpd{}) = False +hsExprNeedsParens (HsWrap _ e) = hsExprNeedsParens e hsExprNeedsParens _ = True isAtomicHsExpr :: HsExpr id -> Bool -- True of a single token isAtomicHsExpr (HsVar {}) = True +isAtomicHsExpr (HsConLikeOut {}) = True isAtomicHsExpr (HsLit {}) = True isAtomicHsExpr (HsOverLit {}) = True isAtomicHsExpr (HsIPVar {}) = True @@ -1178,7 +1200,7 @@ data HsCmd id -- For details on above see note [Api annotations] in ApiAnnotation - | HsCmdLet (Located (HsLocalBinds id)) -- let(rec) + | HsCmdLet (LHsLocalBinds id) -- let(rec) (LHsCmd id) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet', -- 'ApiAnnotation.AnnOpen' @'{'@, @@ -1299,6 +1321,12 @@ ppr_cmd (HsCmdArrForm (L _ (HsVar (L _ v))) _ (Just _) [arg1, arg2]) ppr_cmd (HsCmdArrForm (L _ (HsVar (L _ v))) Infix _ [arg1, arg2]) = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v , pprCmdArg (unLoc arg2)]) +ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut c)) _ (Just _) [arg1, arg2]) + = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c) + , pprCmdArg (unLoc arg2)]) +ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut c)) Infix _ [arg1, arg2]) + = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c) + , pprCmdArg (unLoc arg2)]) ppr_cmd (HsCmdArrForm op _ _ args) = hang (text "(|" <> ppr_lexpr op) 4 (sep (map (pprCmdArg.unLoc) args) <> text "|)") @@ -1452,8 +1480,8 @@ hsLMatchPats (L _ (Match _ pats _ _)) = pats -- For details on above see note [Api annotations] in ApiAnnotation data GRHSs id body = GRHSs { - grhssGRHSs :: [LGRHS id body], -- ^ Guarded RHSs - grhssLocalBinds :: Located (HsLocalBinds id) -- ^ The where clause + grhssGRHSs :: [LGRHS id body], -- ^ Guarded RHSs + grhssLocalBinds :: LHsLocalBinds id -- ^ The where clause } deriving instance (Data body,DataId id) => Data (GRHSs id body) @@ -1511,7 +1539,7 @@ pprMatch match LambdaExpr -> (char '\\', m_pats match) - _ -> ASSERT( null pats1 ) + _ -> ASSERT2( null pats1, ppr ctxt $$ ppr pat1 $$ ppr pats1 ) (ppr pat1, []) -- No parens around the single pat (pat1:pats1) = m_pats match @@ -1640,7 +1668,7 @@ data StmtLR idL idR body -- body should always be (LHs**** idR) -- 'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@, -- For details on above see note [Api annotations] in ApiAnnotation - | LetStmt (Located (HsLocalBindsLR idL idR)) + | LetStmt (LHsLocalBindsLR idL idR) -- ParStmts only occur in a list/monad comprehension | ParStmt [ParStmtBlock idL idR] @@ -2308,6 +2336,19 @@ data HsMatchContext id deriving Functor deriving instance (DataIdPost id) => Data (HsMatchContext id) +instance OutputableBndr id => Outputable (HsMatchContext id) where + ppr (FunRhs (L _ id) fix) = text "FunRhs" <+> ppr id <+> ppr fix + ppr LambdaExpr = text "LambdaExpr" + ppr CaseAlt = text "CaseAlt" + ppr IfAlt = text "IfAlt" + ppr ProcExpr = text "ProcExpr" + ppr PatBindRhs = text "PatBindRhs" + ppr RecUpd = text "RecUpd" + ppr (StmtCtxt _) = text "StmtCtxt _" + ppr ThPatSplice = text "ThPatSplice" + ppr ThPatQuote = text "ThPatQuote" + ppr PatSyn = text "PatSyn" + isPatSynCtxt :: HsMatchContext id -> Bool isPatSynCtxt ctxt = case ctxt of diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index c29f0c25be..174e83702e 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -28,8 +28,8 @@ module HsPat ( mkPrefixConPat, mkCharLitPat, mkNilPat, - isUnliftedHsBind, looksLazyPatBind, - isUnliftedLPat, isBangedLPat, isBangedPatBind, + looksLazyPatBind, + isBangedLPat, isBangedPatBind, hsPatNeedsParens, isIrrefutableHsPat, @@ -555,19 +555,6 @@ patterns are treated specially, of course. The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are. -} -isUnliftedLPat :: LPat id -> Bool -isUnliftedLPat (L _ (ParPat p)) = isUnliftedLPat p -isUnliftedLPat (L _ (TuplePat _ Unboxed _)) = True -isUnliftedLPat (L _ (SumPat _ _ _ _)) = True -isUnliftedLPat _ = False - -isUnliftedHsBind :: HsBind id -> Bool --- A pattern binding with an outermost bang or unboxed tuple or sum must be --- matched strictly. --- Defined in this module because HsPat is above HsBinds in the import graph -isUnliftedHsBind (PatBind { pat_lhs = p }) = isUnliftedLPat p -isUnliftedHsBind _ = False - isBangedPatBind :: HsBind id -> Bool isBangedPatBind (PatBind {pat_lhs = pat}) = isBangedLPat pat isBangedPatBind _ = False @@ -582,15 +569,20 @@ looksLazyPatBind :: HsBind id -> Bool -- a StrictHsBind (as above) or -- a VarPat -- In particular, returns True of a pattern binding with a compound pattern, like (I# x) -looksLazyPatBind (PatBind { pat_lhs = p }) = looksLazyLPat p -looksLazyPatBind _ = False +-- Looks through AbsBinds +looksLazyPatBind (PatBind { pat_lhs = p }) + = looksLazyLPat p +looksLazyPatBind (AbsBinds { abs_binds = binds }) + = anyBag (looksLazyPatBind . unLoc) binds +looksLazyPatBind (AbsBindsSig { abs_sig_bind = L _ bind }) + = looksLazyPatBind bind +looksLazyPatBind _ + = False looksLazyLPat :: LPat id -> Bool looksLazyLPat (L _ (ParPat p)) = looksLazyLPat p looksLazyLPat (L _ (AsPat _ p)) = looksLazyLPat p looksLazyLPat (L _ (BangPat {})) = False -looksLazyLPat (L _ (TuplePat _ Unboxed _)) = False -looksLazyLPat (L _ (SumPat _ _ _ _)) = False looksLazyLPat (L _ (VarPat {})) = False looksLazyLPat (L _ (WildPat {})) = False looksLazyLPat _ = True diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index b49cd98f25..58948cc862 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -28,7 +28,8 @@ module HsUtils( mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo, mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap, - nlHsTyApp, nlHsTyApps, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps, + nlHsTyApp, nlHsTyApps, nlHsVar, nlHsDataCon, + nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps, nlHsIntLit, nlHsVarApps, nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, @@ -71,6 +72,8 @@ module HsUtils( noRebindableInfo, -- Collecting binders + isUnliftedHsBind, + collectLocalBinders, collectHsValBinders, collectHsBindListBinders, collectHsIdBinders, collectHsBindsBinders, collectHsBindBinders, collectMethodBinders, @@ -105,6 +108,8 @@ import Type ( filterOutInvisibleTypes ) import TysWiredIn ( unitTy ) import TcType import DataCon +import ConLike +import Id import Name import NameSet import NameEnv @@ -365,6 +370,10 @@ userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ] nlHsVar :: id -> LHsExpr id nlHsVar n = noLoc (HsVar (noLoc n)) +-- NB: Only for LHsExpr **Id** +nlHsDataCon :: DataCon -> LHsExpr Id +nlHsDataCon con = noLoc (HsConLikeOut (RealDataCon con)) + nlHsLit :: HsLit -> LHsExpr id nlHsLit n = noLoc (HsLit n) @@ -772,9 +781,72 @@ These functions should only be used on HsSyn *after* the renamer, to return a [Name] or [Id]. Before renaming the record punning and wild-card mechanism makes it hard to know what is bound. So these functions should not be applied to (HsSyn RdrName) + +Note [Unlifted id check in isHsUnliftedBind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose there is a binding with the type (Num a => (# a, a #)). Is this a +strict binding that should be disallowed at the top level? At first glance, +no, because it's a function. But consider how this is desugared via +AbsBinds: + + -- x :: Num a => (# a, a #) + x = (# 3, 4 #) + +becomes + + x = \ $dictNum -> + let x_mono = (# fromInteger $dictNum 3, fromInteger $dictNum 4 #) in + x_mono + +Note that the inner let is strict. And thus if we have a bunch of mutually +recursive bindings of this form, we could end up in trouble. This was shown +up in #9140. + +But if there is a type signature on x, everything changes because of the +desugaring used by AbsBindsSig: + + x :: Num a => (# a, a #) + x = (# 3, 4 #) + +becomes + + x = \ $dictNum -> (# fromInteger $dictNum 3, fromInteger $dictNum 4 #) + +No strictness anymore! The bottom line here is that, for inferred types, we +care about the strictness of the type after the =>. For checked types +(AbsBindsSig), we care about the overall strictness. + +This matters. If we don't separate out the AbsBindsSig case, then GHC runs into +a problem when compiling + + undefined :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a + +Looking only after the =>, we cannot tell if this is strict or not. (GHC panics +if you try.) Looking at the whole type, on the other hand, tells you that this +is a lifted function type, with no trouble at all. + -} ----------------- Bindings -------------------------- + +-- | Should we treat this as an unlifted bind? This will be true for any +-- bind that binds an unlifted variable, but we must be careful around +-- AbsBinds. See Note [Unlifted id check in isUnliftedHsBind]. For usage +-- information, see Note [Strict binds check] is DsBinds. +isUnliftedHsBind :: HsBind Id -> Bool -- works only over typechecked binds +isUnliftedHsBind (AbsBindsSig { abs_sig_export = id }) + = isUnliftedType (idType id) +isUnliftedHsBind bind + = any is_unlifted_id (collectHsBindBinders bind) + where + is_unlifted_id id + = case tcSplitSigmaTy (idType id) of + (_, _, tau) -> isUnliftedType tau + -- For the is_unlifted check, we need to look inside polymorphism + -- and overloading. E.g. x = (# 1, True #) + -- would get type forall a. Num a => (# a, Bool #) + -- and we want to reject that. See Trac #9140 + collectLocalBinders :: HsLocalBindsLR idL idR -> [idL] collectLocalBinders (HsValBinds binds) = collectHsIdBinders binds -- No pattern synonyms here diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs index cb5e3a7d05..4c95f90cbc 100644 --- a/compiler/iface/IfaceSyn.hs +++ b/compiler/iface/IfaceSyn.hs @@ -316,6 +316,7 @@ data IfaceInfoItem | HsUnfold Bool -- True <=> isStrongLoopBreaker is true IfaceUnfolding -- See Note [Expose recursive functions] | HsNoCafRefs + | HsLevity -- Present <=> never levity polymorphic -- NB: Specialisations and rules come in separately and are -- only later attached to the Id. Partial reason: some are orphans. @@ -1156,6 +1157,7 @@ instance Outputable IfaceInfoItem where ppr (HsArity arity) = text "Arity:" <+> int arity ppr (HsStrictness str) = text "Strictness:" <+> pprIfaceStrictSig str ppr HsNoCafRefs = text "HasNoCafRefs" + ppr HsLevity = text "Never levity-polymorphic" instance Outputable IfaceUnfolding where ppr (IfCompulsory e) = text "<compulsory>" <+> parens (ppr e) @@ -1817,6 +1819,7 @@ instance Binary IfaceInfoItem where put_ bh (HsUnfold lb ad) = putByte bh 2 >> put_ bh lb >> put_ bh ad put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad put_ bh HsNoCafRefs = putByte bh 4 + put_ bh HsLevity = putByte bh 5 get bh = do h <- getByte bh case h of @@ -1826,7 +1829,8 @@ instance Binary IfaceInfoItem where ad <- get bh return (HsUnfold lb ad) 3 -> liftM HsInline $ get bh - _ -> return HsNoCafRefs + 4 -> return HsNoCafRefs + _ -> return HsLevity instance Binary IfaceUnfolding where put_ bh (IfCoreUnfold s e) = do diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs index b667522007..ad1a3ea0c4 100644 --- a/compiler/iface/IfaceType.hs +++ b/compiler/iface/IfaceType.hs @@ -49,7 +49,7 @@ module IfaceType ( #include "HsVersions.h" -import {-# SOURCE #-} TysWiredIn ( ptrRepLiftedDataConTyCon ) +import {-# SOURCE #-} TysWiredIn ( liftedRepDataConTyCon ) import DynFlags import StaticFlags ( opt_PprStyle_Debug ) @@ -296,7 +296,7 @@ isIfaceLiftedTypeKind (IfaceTyConApp tc ITC_Nil) isIfaceLiftedTypeKind (IfaceTyConApp tc (ITC_Vis (IfaceTyConApp ptr_rep_lifted ITC_Nil) ITC_Nil)) = tc `ifaceTyConHasKey` tYPETyConKey - && ptr_rep_lifted `ifaceTyConHasKey` ptrRepLiftedDataConKey + && ptr_rep_lifted `ifaceTyConHasKey` liftedRepDataConKey isIfaceLiftedTypeKind _ = False splitIfaceSigmaTy :: IfaceType -> ([IfaceForAllBndr], [IfacePredType], IfaceType) @@ -779,7 +779,7 @@ defaultRuntimeRepVars = go emptyFsEnv go subs (IfaceTyVar tv) | tv `elemFsEnv` subs - = IfaceTyConApp ptrRepLifted ITC_Nil + = IfaceTyConApp liftedRep ITC_Nil go subs (IfaceFunTy kind ty) = IfaceFunTy (go subs kind) (go subs ty) @@ -795,10 +795,10 @@ defaultRuntimeRepVars = go emptyFsEnv go _ other = other - ptrRepLifted :: IfaceTyCon - ptrRepLifted = + liftedRep :: IfaceTyCon + liftedRep = IfaceTyCon dc_name (IfaceTyConInfo IsPromoted IfaceNormalTyCon) - where dc_name = getName ptrRepLiftedDataConTyCon + where dc_name = getName liftedRepDataConTyCon isRuntimeRep :: IfaceType -> Bool isRuntimeRep (IfaceTyConApp tc _) = @@ -965,14 +965,9 @@ pprTyTcApp' ctxt_prec tc tys dflags style | tc `ifaceTyConHasKey` tYPETyConKey , ITC_Vis (IfaceTyConApp rep ITC_Nil) ITC_Nil <- tys - , rep `ifaceTyConHasKey` ptrRepLiftedDataConKey + , rep `ifaceTyConHasKey` liftedRepDataConKey = kindStar - | tc `ifaceTyConHasKey` tYPETyConKey - , ITC_Vis (IfaceTyConApp rep ITC_Nil) ITC_Nil <- tys - , rep `ifaceTyConHasKey` ptrRepUnliftedDataConKey - = char '#' - | not opt_PprStyle_Debug , tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey = text "(TypeError ...)" -- Suppress detail unles you _really_ want to see @@ -1055,9 +1050,6 @@ ppr_iface_tc_app pp ctxt_prec tc tys || tc `ifaceTyConHasKey` unicodeStarKindTyConKey = kindStar -- Handle unicode; do not wrap * in parens - | tc `ifaceTyConHasKey` unliftedTypeKindTyConKey - = ppr tc -- Do not wrap # in parens - | not (isSymOcc (nameOccName (ifaceTyConName tc))) = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp TyConPrec) tys) diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs index 3c8742edaf..988860f4af 100644 --- a/compiler/iface/TcIface.hs +++ b/compiler/iface/TcIface.hs @@ -1469,6 +1469,7 @@ tcIdInfo ignore_prags name ty info = do tcPrag info (HsArity arity) = return (info `setArityInfo` arity) tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` str) tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag) + tcPrag info HsLevity = return (info `setNeverLevPoly` ty) -- The next two are lazy, so they don't transitively suck stuff in tcPrag info (HsUnfold lb if_unf) diff --git a/compiler/iface/ToIface.hs b/compiler/iface/ToIface.hs index 8e80bb3d42..696d0ffc0f 100644 --- a/compiler/iface/ToIface.hs +++ b/compiler/iface/ToIface.hs @@ -346,7 +346,7 @@ toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other) toIfaceIdInfo :: IdInfo -> IfaceIdInfo toIfaceIdInfo id_info = case catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, - inline_hsinfo, unfold_hsinfo] of + inline_hsinfo, unfold_hsinfo, levity_hsinfo] of [] -> NoInfo infos -> HasInfo infos -- NB: strictness and arity must appear in the list before unfolding @@ -378,6 +378,10 @@ toIfaceIdInfo id_info inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing | otherwise = Just (HsInline inline_prag) + ------------ Levity polymorphism ---------- + levity_hsinfo | isNeverLevPolyIdInfo id_info = Just HsLevity + | otherwise = Nothing + -------------------------- toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 41f7235ea3..bcd5a25836 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -564,6 +564,10 @@ data GeneralFlag -- displayed. If a warning isn't controlled by a flag, this is made -- explicit at the point of use. data WarnReason = NoReason | Reason !WarningFlag + deriving Show + +instance Outputable WarnReason where + ppr = text . show data WarningFlag = -- See Note [Updating flag description in the User's Guide] @@ -631,6 +635,7 @@ data WarningFlag = | Opt_WarnUnrecognisedWarningFlags -- since 8.0 | Opt_WarnSimplifiableClassConstraints -- Since 8.2 | Opt_WarnCPPUndef -- Since 8.2 + | Opt_WarnUnbangedStrictPatterns -- Since 8.2 deriving (Eq, Show, Enum) data Language = Haskell98 | Haskell2010 @@ -3363,6 +3368,7 @@ wWarningFlagsDeps = [ depFlagSpec "auto-orphans" Opt_WarnAutoOrphans "it has no effect", flagSpec "cpp-undef" Opt_WarnCPPUndef, + flagSpec "unbanged-strict-patterns" Opt_WarnUnbangedStrictPatterns, flagSpec "deferred-type-errors" Opt_WarnDeferredTypeErrors, flagSpec "deferred-out-of-scope-variables" Opt_WarnDeferredOutOfScopeVariables, @@ -4062,7 +4068,8 @@ minusWOpts Opt_WarnUnusedImports, Opt_WarnIncompletePatterns, Opt_WarnDodgyExports, - Opt_WarnDodgyImports + Opt_WarnDodgyImports, + Opt_WarnUnbangedStrictPatterns ] -- | Things you get with -Wall diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index 5b3c058d35..3b44bb1fda 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -2964,4 +2964,3 @@ nameOfObject other = pprPanic "nameOfObject" (ppr other) byteCodeOfObject :: Unlinked -> CompiledByteCode byteCodeOfObject (BCOs bc) = bc byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other) - diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 3c2973d23e..93abb07ec0 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -63,7 +63,6 @@ import Name hiding ( varName ) import NameSet import Avail import RdrName -import VarSet import VarEnv import ByteCodeTypes import Linker @@ -481,9 +480,9 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do -- Filter out any unboxed ids; -- we can't bind these at the prompt pointers = filter (\(id,_) -> isPointer id) vars - isPointer id | UnaryRep ty <- repType (idType id) - , PtrRep <- typePrimRep ty = True - | otherwise = False + isPointer id | [rep] <- typePrimRep (idType id) + , isGcPtrRep rep = True + | otherwise = False (ids, offsets) = unzip pointers @@ -551,7 +550,7 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds) return hsc_env' where - noSkolems = isEmptyVarSet . tyCoVarsOfType . idType + noSkolems = noFreeVarsOfType . idType improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do let tmp_ids = [id | AnId id <- ic_tythings ic] Just id = find (\i -> idName i == name) tmp_ids diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs index e7ad536ca9..fcddcdb84d 100644 --- a/compiler/prelude/PrelNames.hs +++ b/compiler/prelude/PrelNames.hs @@ -1650,12 +1650,11 @@ eitherTyConKey = mkPreludeTyConUnique 84 -- Kind constructors liftedTypeKindTyConKey, tYPETyConKey, - unliftedTypeKindTyConKey, constraintKindTyConKey, + constraintKindTyConKey, starKindTyConKey, unicodeStarKindTyConKey, runtimeRepTyConKey, vecCountTyConKey, vecElemTyConKey :: Unique liftedTypeKindTyConKey = mkPreludeTyConUnique 87 tYPETyConKey = mkPreludeTyConUnique 88 -unliftedTypeKindTyConKey = mkPreludeTyConUnique 89 constraintKindTyConKey = mkPreludeTyConUnique 92 starKindTyConKey = mkPreludeTyConUnique 93 unicodeStarKindTyConKey = mkPreludeTyConUnique 94 @@ -1895,25 +1894,27 @@ metaDataDataConKey = mkPreludeDataConUnique 68 metaConsDataConKey = mkPreludeDataConUnique 69 metaSelDataConKey = mkPreludeDataConUnique 70 -vecRepDataConKey :: Unique +vecRepDataConKey, tupleRepDataConKey, sumRepDataConKey :: Unique vecRepDataConKey = mkPreludeDataConUnique 71 +tupleRepDataConKey = mkPreludeDataConUnique 72 +sumRepDataConKey = mkPreludeDataConUnique 73 -- See Note [Wiring in RuntimeRep] in TysWiredIn runtimeRepSimpleDataConKeys :: [Unique] -ptrRepLiftedDataConKey, ptrRepUnliftedDataConKey :: Unique +liftedRepDataConKey :: Unique runtimeRepSimpleDataConKeys@( - ptrRepLiftedDataConKey : ptrRepUnliftedDataConKey : _) - = map mkPreludeDataConUnique [72..83] + liftedRepDataConKey : _) + = map mkPreludeDataConUnique [74..82] -- See Note [Wiring in RuntimeRep] in TysWiredIn -- VecCount vecCountDataConKeys :: [Unique] -vecCountDataConKeys = map mkPreludeDataConUnique [84..89] +vecCountDataConKeys = map mkPreludeDataConUnique [83..88] -- See Note [Wiring in RuntimeRep] in TysWiredIn -- VecElem vecElemDataConKeys :: [Unique] -vecElemDataConKeys = map mkPreludeDataConUnique [90..99] +vecElemDataConKeys = map mkPreludeDataConUnique [89..98] ---------------- Template Haskell ------------------- -- THNames.hs: USES DataUniques 100-150 @@ -2309,5 +2310,4 @@ pretendNameIsInScope :: Name -> Bool pretendNameIsInScope n = any (n `hasKey`) [ starKindTyConKey, liftedTypeKindTyConKey, tYPETyConKey - , unliftedTypeKindTyConKey - , runtimeRepTyConKey, ptrRepLiftedDataConKey, ptrRepUnliftedDataConKey ] + , runtimeRepTyConKey, liftedRepDataConKey ] diff --git a/compiler/prelude/PrimOp.hs b/compiler/prelude/PrimOp.hs index 0acac6639f..41458b0e15 100644 --- a/compiler/prelude/PrimOp.hs +++ b/compiler/prelude/PrimOp.hs @@ -37,7 +37,7 @@ import Demand import OccName ( OccName, pprOccName, mkVarOccFS ) import TyCon ( TyCon, isPrimTyCon, PrimRep(..) ) import Type -import RepType ( typePrimRep, tyConPrimRep ) +import RepType ( typePrimRep1, tyConPrimRep1 ) import BasicTypes ( Arity, Fixity(..), FixityDirection(..), Boxity(..), SourceText(..) ) import ForeignCall ( CLabelString ) @@ -579,10 +579,10 @@ data PrimOpResultInfo getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo getPrimOpResultInfo op = case (primOpInfo op) of - Dyadic _ ty -> ReturnsPrim (typePrimRep ty) - Monadic _ ty -> ReturnsPrim (typePrimRep ty) - Compare _ _ -> ReturnsPrim (tyConPrimRep intPrimTyCon) - GenPrimOp _ _ _ ty | isPrimTyCon tc -> ReturnsPrim (tyConPrimRep tc) + Dyadic _ ty -> ReturnsPrim (typePrimRep1 ty) + Monadic _ ty -> ReturnsPrim (typePrimRep1 ty) + Compare _ _ -> ReturnsPrim (tyConPrimRep1 intPrimTyCon) + GenPrimOp _ _ _ ty | isPrimTyCon tc -> ReturnsPrim (tyConPrimRep1 tc) | otherwise -> ReturnsAlg tc where tc = tyConAppTyCon ty diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs index dce0369edf..98064841c1 100644 --- a/compiler/prelude/TysPrim.hs +++ b/compiler/prelude/TysPrim.hs @@ -24,10 +24,10 @@ module TysPrim( openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, -- Kind constructors... - tYPETyConName, unliftedTypeKindTyConName, + tYPETyConName, -- Kinds - tYPE, + tYPE, primRepToRuntimeRep, funTyCon, funTyConName, primTyCons, @@ -81,9 +81,9 @@ module TysPrim( #include "HsVersions.h" import {-# SOURCE #-} TysWiredIn - ( runtimeRepTy, liftedTypeKind - , vecRepDataConTyCon, ptrRepUnliftedDataConTyCon - , voidRepDataConTy, intRepDataConTy + ( runtimeRepTy, unboxedTupleKind, liftedTypeKind + , vecRepDataConTyCon, tupleRepDataConTyCon + , liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy , wordRepDataConTy, int64RepDataConTy, word64RepDataConTy, addrRepDataConTy , floatRepDataConTy, doubleRepDataConTy , vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy @@ -91,7 +91,8 @@ import {-# SOURCE #-} TysWiredIn , int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy , int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy , word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy - , doubleElemRepDataConTy ) + , doubleElemRepDataConTy + , mkPromotedListTy ) import Var ( TyVar, mkTyVar ) import Name @@ -151,7 +152,6 @@ primTyCons , eqReprPrimTyCon , eqPhantPrimTyCon - , unliftedTypeKindTyCon , tYPETyCon #include "primop-vector-tycons.hs-incl" @@ -356,25 +356,26 @@ Note [TYPE and RuntimeRep] All types that classify values have a kind of the form (TYPE rr), where data RuntimeRep -- Defined in ghc-prim:GHC.Types - = PtrRepLifted - | PtrRepUnlifted + = LiftedRep + | UnliftedRep | IntRep | FloatRep .. etc .. rr :: RuntimeRep - TYPE :: RuntimeRep -> TYPE 'PtrRepLifted -- Built in + TYPE :: RuntimeRep -> TYPE 'LiftedRep -- Built in So for example: - Int :: TYPE 'PtrRepLifted - Array# Int :: TYPE 'PtrRepUnlifted + Int :: TYPE 'LiftedRep + Array# Int :: TYPE 'UnliftedRep Int# :: TYPE 'IntRep Float# :: TYPE 'FloatRep - Maybe :: TYPE 'PtrRepLifted -> TYPE 'PtrRepLifted + Maybe :: TYPE 'LiftedRep -> TYPE 'LiftedRep + (# , #) :: TYPE r1 -> TYPE r2 -> TYPE (TupleRep [r1, r2]) We abbreviate '*' specially: - type * = TYPE 'PtrRepLifted + type * = TYPE 'LiftedRep The 'rr' parameter tells us how the value is represented at runime. @@ -402,22 +403,12 @@ generator never has to manipulate a value of type 'a :: TYPE rr'. Always inlined, and hence specialised to the call site (#,#) :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) (a :: TYPE r1) (b :: TYPE r2). - a -> b -> TYPE 'UnboxedTupleRep - See Note [Unboxed tuple kinds] - -Note [Unboxed tuple kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -What kind does (# Int, Float# #) have? -The "right" answer would be - TYPE ('UnboxedTupleRep [PtrRepLifted, FloatRep]) -Currently we do not do this. We just have - (# Int, Float# #) :: TYPE 'UnboxedTupleRep -which does not tell us exactly how is is represented. + a -> b -> TYPE ('TupleRep '[r1, r2]) Note [PrimRep and kindPrimRep] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As part of its source code, in TyCon, GHC has - data PrimRep = PtrRep | IntRep | FloatRep | ...etc... + data PrimRep = LiftedRep | UnliftedRep | IntRep | FloatRep | ...etc... Notice that * RuntimeRep is part of the syntax tree of the program being compiled @@ -439,8 +430,8 @@ PrimRep in the promoted data constructor itself: see TyCon.promDcRepInfo. -} -tYPETyCon, unliftedTypeKindTyCon :: TyCon -tYPETyConName, unliftedTypeKindTyConName :: Name +tYPETyCon :: TyCon +tYPETyConName :: Name tYPETyCon = mkKindTyCon tYPETyConName (mkTemplateAnonTyConBinders [runtimeRepTy]) @@ -448,22 +439,12 @@ tYPETyCon = mkKindTyCon tYPETyConName [Nominal] (mkPrelTyConRepName tYPETyConName) - -- See Note [TYPE and RuntimeRep] - -- NB: unlifted is wired in because there is no way to parse it in - -- Haskell. That's the only reason for wiring it in. -unliftedTypeKindTyCon = mkSynonymTyCon unliftedTypeKindTyConName - [] liftedTypeKind [] - (tYPE (TyConApp ptrRepUnliftedDataConTyCon [])) - True -- no foralls - True -- family free - -------------------------- -- ... and now their names -- If you edit these, you may need to update the GHC formalism -- See Note [GHC Formalism] in coreSyn/CoreLint.hs tYPETyConName = mkPrimTyConName (fsLit "TYPE") tYPETyConKey tYPETyCon -unliftedTypeKindTyConName = mkPrimTyConName (fsLit "#") unliftedTypeKindTyConKey unliftedTypeKindTyCon mkPrimTyConName :: FastString -> Unique -> TyCon -> Name mkPrimTyConName = mkPrimTcName BuiltInSyntax @@ -494,41 +475,44 @@ pcPrimTyCon name roles rep = mkPrimTyCon name binders result_kind roles where binders = mkTemplateAnonTyConBinders (map (const liftedTypeKind) roles) - result_kind = tYPE rr - - rr = case rep of - VoidRep -> voidRepDataConTy - PtrRep -> TyConApp ptrRepUnliftedDataConTyCon [] - IntRep -> intRepDataConTy - WordRep -> wordRepDataConTy - Int64Rep -> int64RepDataConTy - Word64Rep -> word64RepDataConTy - AddrRep -> addrRepDataConTy - FloatRep -> floatRepDataConTy - DoubleRep -> doubleRepDataConTy - VecRep n elem -> TyConApp vecRepDataConTyCon [n', elem'] - where - n' = case n of - 2 -> vec2DataConTy - 4 -> vec4DataConTy - 8 -> vec8DataConTy - 16 -> vec16DataConTy - 32 -> vec32DataConTy - 64 -> vec64DataConTy - _ -> pprPanic "Disallowed VecCount" (ppr n) - - elem' = case elem of - Int8ElemRep -> int8ElemRepDataConTy - Int16ElemRep -> int16ElemRepDataConTy - Int32ElemRep -> int32ElemRepDataConTy - Int64ElemRep -> int64ElemRepDataConTy - Word8ElemRep -> word8ElemRepDataConTy - Word16ElemRep -> word16ElemRepDataConTy - Word32ElemRep -> word32ElemRepDataConTy - Word64ElemRep -> word64ElemRepDataConTy - FloatElemRep -> floatElemRepDataConTy - DoubleElemRep -> doubleElemRepDataConTy - + result_kind = tYPE (primRepToRuntimeRep rep) + +-- | Convert a 'PrimRep' to a 'Type' of kind RuntimeRep +-- Defined here to avoid (more) module loops +primRepToRuntimeRep :: PrimRep -> Type +primRepToRuntimeRep rep = case rep of + VoidRep -> TyConApp tupleRepDataConTyCon [mkPromotedListTy runtimeRepTy []] + LiftedRep -> liftedRepDataConTy + UnliftedRep -> unliftedRepDataConTy + IntRep -> intRepDataConTy + WordRep -> wordRepDataConTy + Int64Rep -> int64RepDataConTy + Word64Rep -> word64RepDataConTy + AddrRep -> addrRepDataConTy + FloatRep -> floatRepDataConTy + DoubleRep -> doubleRepDataConTy + VecRep n elem -> TyConApp vecRepDataConTyCon [n', elem'] + where + n' = case n of + 2 -> vec2DataConTy + 4 -> vec4DataConTy + 8 -> vec8DataConTy + 16 -> vec16DataConTy + 32 -> vec32DataConTy + 64 -> vec64DataConTy + _ -> pprPanic "Disallowed VecCount" (ppr n) + + elem' = case elem of + Int8ElemRep -> int8ElemRepDataConTy + Int16ElemRep -> int16ElemRepDataConTy + Int32ElemRep -> int32ElemRepDataConTy + Int64ElemRep -> int64ElemRepDataConTy + Word8ElemRep -> word8ElemRepDataConTy + Word16ElemRep -> word16ElemRepDataConTy + Word32ElemRep -> word32ElemRepDataConTy + Word64ElemRep -> word64ElemRepDataConTy + FloatElemRep -> floatElemRepDataConTy + DoubleElemRep -> doubleElemRepDataConTy pcPrimTyCon0 :: Name -> PrimRep -> TyCon pcPrimTyCon0 name rep @@ -799,7 +783,7 @@ proxyPrimTyCon = mkPrimTyCon proxyPrimTyConName binders res_kind [Nominal,Nomina where -- Kind: forall k. k -> Void# binders = mkTemplateTyConBinders [liftedTypeKind] (\ks-> ks) - res_kind = tYPE voidRepDataConTy + res_kind = unboxedTupleKind [] {- ********************************************************************* @@ -815,7 +799,7 @@ eqPrimTyCon = mkPrimTyCon eqPrimTyConName binders res_kind roles where -- Kind :: forall k1 k2. k1 -> k2 -> Void# binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] (\ks -> ks) - res_kind = tYPE voidRepDataConTy + res_kind = unboxedTupleKind [] roles = [Nominal, Nominal, Nominal, Nominal] -- like eqPrimTyCon, but the type for *Representational* coercions @@ -826,7 +810,7 @@ eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName binders res_kind roles where -- Kind :: forall k1 k2. k1 -> k2 -> Void# binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] (\ks -> ks) - res_kind = tYPE voidRepDataConTy + res_kind = unboxedTupleKind [] roles = [Nominal, Nominal, Representational, Representational] -- like eqPrimTyCon, but the type for *Phantom* coercions. @@ -837,7 +821,7 @@ eqPhantPrimTyCon = mkPrimTyCon eqPhantPrimTyConName binders res_kind roles where -- Kind :: forall k1 k2. k1 -> k2 -> Void# binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] (\ks -> ks) - res_kind = tYPE voidRepDataConTy + res_kind = unboxedTupleKind [] roles = [Nominal, Nominal, Phantom, Phantom] {- ********************************************************************* @@ -849,14 +833,14 @@ eqPhantPrimTyCon = mkPrimTyCon eqPhantPrimTyConName binders res_kind roles arrayPrimTyCon, mutableArrayPrimTyCon, mutableByteArrayPrimTyCon, byteArrayPrimTyCon, arrayArrayPrimTyCon, mutableArrayArrayPrimTyCon, smallArrayPrimTyCon, smallMutableArrayPrimTyCon :: TyCon -arrayPrimTyCon = pcPrimTyCon arrayPrimTyConName [Representational] PtrRep -mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConName [Nominal, Representational] PtrRep -mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConName [Nominal] PtrRep -byteArrayPrimTyCon = pcPrimTyCon0 byteArrayPrimTyConName PtrRep -arrayArrayPrimTyCon = pcPrimTyCon0 arrayArrayPrimTyConName PtrRep -mutableArrayArrayPrimTyCon = pcPrimTyCon mutableArrayArrayPrimTyConName [Nominal] PtrRep -smallArrayPrimTyCon = pcPrimTyCon smallArrayPrimTyConName [Representational] PtrRep -smallMutableArrayPrimTyCon = pcPrimTyCon smallMutableArrayPrimTyConName [Nominal, Representational] PtrRep +arrayPrimTyCon = pcPrimTyCon arrayPrimTyConName [Representational] UnliftedRep +mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConName [Nominal, Representational] UnliftedRep +mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConName [Nominal] UnliftedRep +byteArrayPrimTyCon = pcPrimTyCon0 byteArrayPrimTyConName UnliftedRep +arrayArrayPrimTyCon = pcPrimTyCon0 arrayArrayPrimTyConName UnliftedRep +mutableArrayArrayPrimTyCon = pcPrimTyCon mutableArrayArrayPrimTyConName [Nominal] UnliftedRep +smallArrayPrimTyCon = pcPrimTyCon smallArrayPrimTyConName [Representational] UnliftedRep +smallMutableArrayPrimTyCon = pcPrimTyCon smallMutableArrayPrimTyConName [Nominal, Representational] UnliftedRep mkArrayPrimTy :: Type -> Type mkArrayPrimTy elt = TyConApp arrayPrimTyCon [elt] @@ -883,7 +867,7 @@ mkSmallMutableArrayPrimTy s elt = TyConApp smallMutableArrayPrimTyCon [s, elt] ********************************************************************* -} mutVarPrimTyCon :: TyCon -mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName [Nominal, Representational] PtrRep +mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName [Nominal, Representational] UnliftedRep mkMutVarPrimTy :: Type -> Type -> Type mkMutVarPrimTy s elt = TyConApp mutVarPrimTyCon [s, elt] @@ -897,7 +881,7 @@ mkMutVarPrimTy s elt = TyConApp mutVarPrimTyCon [s, elt] -} mVarPrimTyCon :: TyCon -mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName [Nominal, Representational] PtrRep +mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName [Nominal, Representational] UnliftedRep mkMVarPrimTy :: Type -> Type -> Type mkMVarPrimTy s elt = TyConApp mVarPrimTyCon [s, elt] @@ -911,7 +895,7 @@ mkMVarPrimTy s elt = TyConApp mVarPrimTyCon [s, elt] -} tVarPrimTyCon :: TyCon -tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName [Nominal, Representational] PtrRep +tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName [Nominal, Representational] UnliftedRep mkTVarPrimTy :: Type -> Type -> Type mkTVarPrimTy s elt = TyConApp tVarPrimTyCon [s, elt] @@ -939,7 +923,7 @@ mkStablePtrPrimTy ty = TyConApp stablePtrPrimTyCon [ty] -} stableNamePrimTyCon :: TyCon -stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName [Representational] PtrRep +stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName [Representational] UnliftedRep mkStableNamePrimTy :: Type -> Type mkStableNamePrimTy ty = TyConApp stableNamePrimTyCon [ty] @@ -953,7 +937,7 @@ mkStableNamePrimTy ty = TyConApp stableNamePrimTyCon [ty] -} compactPrimTyCon :: TyCon -compactPrimTyCon = pcPrimTyCon0 compactPrimTyConName PtrRep +compactPrimTyCon = pcPrimTyCon0 compactPrimTyConName UnliftedRep compactPrimTy :: Type compactPrimTy = mkTyConTy compactPrimTyCon @@ -969,7 +953,7 @@ compactPrimTy = mkTyConTy compactPrimTyCon bcoPrimTy :: Type bcoPrimTy = mkTyConTy bcoPrimTyCon bcoPrimTyCon :: TyCon -bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName PtrRep +bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName UnliftedRep {- ************************************************************************ @@ -980,7 +964,7 @@ bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName PtrRep -} weakPrimTyCon :: TyCon -weakPrimTyCon = pcPrimTyCon weakPrimTyConName [Representational] PtrRep +weakPrimTyCon = pcPrimTyCon weakPrimTyConName [Representational] UnliftedRep mkWeakPrimTy :: Type -> Type mkWeakPrimTy v = TyConApp weakPrimTyCon [v] @@ -1005,7 +989,7 @@ to the thread id internally. threadIdPrimTy :: Type threadIdPrimTy = mkTyConTy threadIdPrimTyCon threadIdPrimTyCon :: TyCon -threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName PtrRep +threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName UnliftedRep {- ************************************************************************ diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs index 1aea16aabc..66eb396fc8 100644 --- a/compiler/prelude/TysWiredIn.hs +++ b/compiler/prelude/TysWiredIn.hs @@ -62,7 +62,7 @@ module TysWiredIn ( nilDataCon, nilDataConName, nilDataConKey, consDataCon_RDR, consDataCon, consDataConName, promotedNilDataCon, promotedConsDataCon, - mkListTy, + mkListTy, mkPromotedListTy, -- * Maybe maybeTyCon, maybeTyConName, @@ -76,6 +76,8 @@ module TysWiredIn ( unitTyCon, unitDataCon, unitDataConId, unitTy, unitTyConKey, pairTyCon, unboxedUnitTyCon, unboxedUnitDataCon, + unboxedTupleKind, unboxedSumKind, + -- ** Constraint tuples cTupleTyConName, cTupleTyConNames, isCTupleTyConName, cTupleDataConName, cTupleDataConNames, @@ -89,7 +91,7 @@ module TysWiredIn ( -- * Kinds typeNatKindCon, typeNatKind, typeSymbolKindCon, typeSymbolKind, isLiftedTypeKindTyConName, liftedTypeKind, constraintKind, - starKindTyCon, starKindTyConName, unboxedTupleKind, + starKindTyCon, starKindTyConName, unicodeStarKindTyCon, unicodeStarKindTyConName, liftedTypeKindTyCon, constraintKindTyCon, @@ -105,14 +107,13 @@ module TysWiredIn ( -- * RuntimeRep and friends runtimeRepTyCon, vecCountTyCon, vecElemTyCon, - runtimeRepTy, ptrRepLiftedTy, ptrRepLiftedDataCon, ptrRepLiftedDataConTyCon, + runtimeRepTy, liftedRepTy, liftedRepDataCon, liftedRepDataConTyCon, - vecRepDataConTyCon, ptrRepUnliftedDataConTyCon, + vecRepDataConTyCon, tupleRepDataConTyCon, sumRepDataConTyCon, - voidRepDataConTy, intRepDataConTy, + liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy, wordRepDataConTy, int64RepDataConTy, word64RepDataConTy, addrRepDataConTy, - floatRepDataConTy, doubleRepDataConTy, unboxedTupleRepDataConTy, - unboxedSumRepDataConTy, + floatRepDataConTy, doubleRepDataConTy, vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, vec64DataConTy, @@ -140,6 +141,7 @@ import Id import Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE ) import Module ( Module ) import Type +import RepType import DataCon import {-# SOURCE #-} ConLike import TyCon @@ -340,7 +342,7 @@ It has these properties: environment (e.g. see Rules.matchRule for one example) * If (Any k) is the type of a value, it must be a /lifted/ value. So - if we have (Any @(TYPE rr)) then rr must be 'PtrRepLifted. See + if we have (Any @(TYPE rr)) then rr must be 'LiftedRep. See Note [TYPE and RuntimeRep] in TysPrim. This is a convenient invariant, and makes isUnliftedTyCon well-defined; otherwise what would (isUnliftedTyCon Any) be? @@ -401,19 +403,20 @@ liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type") starKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "*") starKindTyConKey starKindTyCon unicodeStarKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "★") unicodeStarKindTyConKey unicodeStarKindTyCon -runtimeRepTyConName, vecRepDataConName :: Name +runtimeRepTyConName, vecRepDataConName, tupleRepDataConName, sumRepDataConName :: Name runtimeRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeRep") runtimeRepTyConKey runtimeRepTyCon vecRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "VecRep") vecRepDataConKey vecRepDataCon +tupleRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "TupleRep") tupleRepDataConKey tupleRepDataCon +sumRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "SumRep") sumRepDataConKey sumRepDataCon -- See Note [Wiring in RuntimeRep] runtimeRepSimpleDataConNames :: [Name] runtimeRepSimpleDataConNames = zipWith3Lazy mk_special_dc_name - [ fsLit "PtrRepLifted", fsLit "PtrRepUnlifted" - , fsLit "VoidRep", fsLit "IntRep" + [ fsLit "LiftedRep", fsLit "UnliftedRep" + , fsLit "IntRep" , fsLit "WordRep", fsLit "Int64Rep", fsLit "Word64Rep" - , fsLit "AddrRep", fsLit "FloatRep", fsLit "DoubleRep" - , fsLit "UnboxedTupleRep", fsLit "UnboxedSumRep" ] + , fsLit "AddrRep", fsLit "FloatRep", fsLit "DoubleRep" ] runtimeRepSimpleDataConKeys runtimeRepSimpleDataCons @@ -575,10 +578,9 @@ constraintKindTyCon :: TyCon constraintKindTyCon = pcTyCon False constraintKindTyConName Nothing [] [] -liftedTypeKind, constraintKind, unboxedTupleKind :: Kind -liftedTypeKind = tYPE ptrRepLiftedTy +liftedTypeKind, constraintKind :: Kind +liftedTypeKind = tYPE liftedRepTy constraintKind = mkTyConApp constraintKindTyCon [] -unboxedTupleKind = tYPE unboxedTupleRepDataConTy -- mkFunKind and mkForAllKind are defined here -- solely so that TyCon can use them via a SOURCE import @@ -814,6 +816,18 @@ boxedTupleArr, unboxedTupleArr :: Array Int (TyCon,DataCon) boxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Boxed i | i <- [0..mAX_TUPLE_SIZE]] unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mAX_TUPLE_SIZE]] +-- | Given the TupleRep/SumRep tycon and list of RuntimeReps of the unboxed +-- tuple/sum arguments, produces the return kind of an unboxed tuple/sum type +-- constructor. @unboxedTupleSumKind [IntRep, LiftedRep] --> TYPE (TupleRep/SumRep +-- [IntRep, LiftedRep])@ +unboxedTupleSumKind :: TyCon -> [Type] -> Kind +unboxedTupleSumKind tc rr_tys + = tYPE (mkTyConApp tc [mkPromotedListTy runtimeRepTy rr_tys]) + +-- | Specialization of 'unboxedTupleSumKind' for tuples +unboxedTupleKind :: [Type] -> Kind +unboxedTupleKind = unboxedTupleSumKind tupleRepDataConTyCon + mk_tuple :: Boxity -> Int -> (TyCon,DataCon) mk_tuple Boxed arity = (tycon, tuple_con) where @@ -848,15 +862,14 @@ mk_tuple Unboxed arity = (tycon, tuple_con) tc_binders = mkTemplateTyConBinders (nOfThem arity runtimeRepTy) (\ks -> map tYPE ks) - tc_res_kind | arity == 0 = tYPE voidRepDataConTy -- Nullary unboxed tuple - | otherwise = unboxedTupleKind + tc_res_kind = unboxedTupleKind rr_tys tc_arity = arity * 2 flavour = UnboxedAlgTyCon - dc_tvs = binderVars tc_binders - dc_arg_tys = mkTyVarTys (drop arity dc_tvs) - tuple_con = pcDataCon dc_name dc_tvs dc_arg_tys tycon + dc_tvs = binderVars tc_binders + (rr_tys, dc_arg_tys) = splitAt arity (mkTyVarTys dc_tvs) + tuple_con = pcDataCon dc_name dc_tvs dc_arg_tys tycon boxity = Unboxed modu = gHC_PRIM @@ -952,6 +965,10 @@ sumDataCon alt arity unboxedSumArr :: Array Int (TyCon, Array Int DataCon) unboxedSumArr = listArray (2,mAX_SUM_SIZE) [mk_sum i | i <- [2..mAX_SUM_SIZE]] +-- | Specialization of 'unboxedTupleSumKind' for sums +unboxedSumKind :: [Type] -> Kind +unboxedSumKind = unboxedTupleSumKind sumRepDataConTyCon + -- | Create type constructor and data constructors for n-ary unboxed sum. mk_sum :: Arity -> (TyCon, Array ConTagZ DataCon) mk_sum arity = (tycon, sum_cons) @@ -962,12 +979,11 @@ mk_sum arity = (tycon, sum_cons) tc_binders = mkTemplateTyConBinders (nOfThem arity runtimeRepTy) (\ks -> map tYPE ks) - tyvars = mkTemplateTyVars (replicate arity runtimeRepTy ++ - map (tYPE . mkTyVarTy) (take arity tyvars)) + tyvars = binderVars tc_binders - tc_res_kind = tYPE unboxedSumRepDataConTy + tc_res_kind = unboxedSumKind rr_tys - open_tvs = drop arity tyvars + (rr_tys, tyvar_tys) = splitAt arity (mkTyVarTys tyvars) tc_name = mkWiredInName gHC_PRIM (mkSumTyConOcc arity) tc_uniq (ATyCon tycon) BuiltInSyntax @@ -984,7 +1000,7 @@ mk_sum arity = (tycon, sum_cons) (AConLike (RealDataCon dc)) BuiltInSyntax in dc - tyvar_tys = mkTyVarTys open_tvs + tc_uniq = mkSumTyConUnique arity dc_uniq i = mkSumDataConUnique i arity @@ -1062,25 +1078,26 @@ runtimeRepTy = mkTyConTy runtimeRepTyCon liftedTypeKindTyCon, starKindTyCon, unicodeStarKindTyCon :: TyCon -- Type syononyms; see Note [TYPE and RuntimeRep] in TysPrim --- type Type = tYPE 'PtrRepLifted --- type * = tYPE 'PtrRepLifted --- type * = tYPE 'PtrRepLifted -- Unicode variant +-- type Type = tYPE 'LiftedRep +-- type * = tYPE 'LiftedRep +-- type * = tYPE 'LiftedRep -- Unicode variant liftedTypeKindTyCon = buildSynTyCon liftedTypeKindTyConName [] liftedTypeKind [] - (tYPE ptrRepLiftedTy) + (tYPE liftedRepTy) starKindTyCon = buildSynTyCon starKindTyConName [] liftedTypeKind [] - (tYPE ptrRepLiftedTy) + (tYPE liftedRepTy) unicodeStarKindTyCon = buildSynTyCon unicodeStarKindTyConName [] liftedTypeKind [] - (tYPE ptrRepLiftedTy) + (tYPE liftedRepTy) runtimeRepTyCon :: TyCon runtimeRepTyCon = pcNonEnumTyCon runtimeRepTyConName Nothing [] - (vecRepDataCon : runtimeRepSimpleDataCons) + (vecRepDataCon : tupleRepDataCon : + sumRepDataCon : runtimeRepSimpleDataCons) vecRepDataCon :: DataCon vecRepDataCon = pcSpecialDataCon vecRepDataConName [ mkTyConTy vecCountTyCon @@ -1091,37 +1108,64 @@ vecRepDataCon = pcSpecialDataCon vecRepDataConName [ mkTyConTy vecCountTyCon prim_rep_fun [count, elem] | VecCount n <- tyConRuntimeRepInfo (tyConAppTyCon count) , VecElem e <- tyConRuntimeRepInfo (tyConAppTyCon elem) - = VecRep n e + = [VecRep n e] prim_rep_fun args = pprPanic "vecRepDataCon" (ppr args) vecRepDataConTyCon :: TyCon vecRepDataConTyCon = promoteDataCon vecRepDataCon -ptrRepUnliftedDataConTyCon :: TyCon -ptrRepUnliftedDataConTyCon = promoteDataCon ptrRepUnliftedDataCon +tupleRepDataCon :: DataCon +tupleRepDataCon = pcSpecialDataCon tupleRepDataConName [ mkListTy runtimeRepTy ] + runtimeRepTyCon (RuntimeRep prim_rep_fun) + where + prim_rep_fun [rr_ty_list] + = concatMap (runtimeRepPrimRep doc) rr_tys + where + rr_tys = extractPromotedList rr_ty_list + doc = text "tupleRepDataCon" <+> ppr rr_tys + prim_rep_fun args + = pprPanic "tupleRepDataCon" (ppr args) + +tupleRepDataConTyCon :: TyCon +tupleRepDataConTyCon = promoteDataCon tupleRepDataCon + +sumRepDataCon :: DataCon +sumRepDataCon = pcSpecialDataCon sumRepDataConName [ mkListTy runtimeRepTy ] + runtimeRepTyCon (RuntimeRep prim_rep_fun) + where + prim_rep_fun [rr_ty_list] + = map slotPrimRep (ubxSumRepType prim_repss) + where + rr_tys = extractPromotedList rr_ty_list + doc = text "sumRepDataCon" <+> ppr rr_tys + prim_repss = map (runtimeRepPrimRep doc) rr_tys + prim_rep_fun args + = pprPanic "sumRepDataCon" (ppr args) + +sumRepDataConTyCon :: TyCon +sumRepDataConTyCon = promoteDataCon sumRepDataCon -- See Note [Wiring in RuntimeRep] runtimeRepSimpleDataCons :: [DataCon] -ptrRepLiftedDataCon, ptrRepUnliftedDataCon :: DataCon -runtimeRepSimpleDataCons@(ptrRepLiftedDataCon : ptrRepUnliftedDataCon : _) +liftedRepDataCon :: DataCon +runtimeRepSimpleDataCons@(liftedRepDataCon : _) = zipWithLazy mk_runtime_rep_dc - [ PtrRep, PtrRep, VoidRep, IntRep, WordRep, Int64Rep - , Word64Rep, AddrRep, FloatRep, DoubleRep - , panic "unboxed tuple PrimRep", panic "unboxed sum PrimRep" ] + [ LiftedRep, UnliftedRep, IntRep, WordRep, Int64Rep + , Word64Rep, AddrRep, FloatRep, DoubleRep ] runtimeRepSimpleDataConNames where mk_runtime_rep_dc primrep name - = pcSpecialDataCon name [] runtimeRepTyCon (RuntimeRep (\_ -> primrep)) + = pcSpecialDataCon name [] runtimeRepTyCon (RuntimeRep (\_ -> [primrep])) -- See Note [Wiring in RuntimeRep] -voidRepDataConTy, intRepDataConTy, wordRepDataConTy, int64RepDataConTy, - word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy, - unboxedTupleRepDataConTy, unboxedSumRepDataConTy :: Type -[_, _, voidRepDataConTy, intRepDataConTy, wordRepDataConTy, int64RepDataConTy, - word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy, - unboxedTupleRepDataConTy, unboxedSumRepDataConTy] = map (mkTyConTy . promoteDataCon) - runtimeRepSimpleDataCons +liftedRepDataConTy, unliftedRepDataConTy, + intRepDataConTy, wordRepDataConTy, int64RepDataConTy, + word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy :: Type +[liftedRepDataConTy, unliftedRepDataConTy, + intRepDataConTy, wordRepDataConTy, int64RepDataConTy, + word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy] + = map (mkTyConTy . promoteDataCon) runtimeRepSimpleDataCons vecCountTyCon :: TyCon vecCountTyCon = pcNonEnumTyCon vecCountTyConName Nothing [] @@ -1167,12 +1211,12 @@ int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, doubleElemRepDataConTy] = map (mkTyConTy . promoteDataCon) vecElemDataCons -ptrRepLiftedDataConTyCon :: TyCon -ptrRepLiftedDataConTyCon = promoteDataCon ptrRepLiftedDataCon +liftedRepDataConTyCon :: TyCon +liftedRepDataConTyCon = promoteDataCon liftedRepDataCon --- The type ('PtrRepLifted) -ptrRepLiftedTy :: Type -ptrRepLiftedTy = mkTyConTy ptrRepLiftedDataConTyCon +-- The type ('LiftedRep) +liftedRepTy :: Type +liftedRepTy = mkTyConTy liftedRepDataConTyCon {- ********************************************************************* * * @@ -1570,3 +1614,36 @@ promotedGTDataCon = promoteDataCon gtDataCon promotedConsDataCon, promotedNilDataCon :: TyCon promotedConsDataCon = promoteDataCon consDataCon promotedNilDataCon = promoteDataCon nilDataCon + +-- | Make a *promoted* list. +mkPromotedListTy :: Kind -- ^ of the elements of the list + -> [Type] -- ^ elements + -> Type +mkPromotedListTy k tys + = foldr cons nil tys + where + cons :: Type -- element + -> Type -- list + -> Type + cons elt list = mkTyConApp promotedConsDataCon [k, elt, list] + + nil :: Type + nil = mkTyConApp promotedNilDataCon [k] + +-- | Extract the elements of a promoted list. Panics if the type is not a +-- promoted list +extractPromotedList :: Type -- ^ The promoted list + -> [Type] +extractPromotedList tys = go tys + where + go list_ty + | Just (tc, [_k, t, ts]) <- splitTyConApp_maybe list_ty + = ASSERT( tc `hasKey` consDataConKey ) + t : go ts + + | Just (tc, [_k]) <- splitTyConApp_maybe list_ty + = ASSERT( tc `hasKey` nilDataConKey ) + [] + + | otherwise + = pprPanic "extractPromotedList" (ppr tys) diff --git a/compiler/prelude/TysWiredIn.hs-boot b/compiler/prelude/TysWiredIn.hs-boot index 7b7229c977..26e42010c9 100644 --- a/compiler/prelude/TysWiredIn.hs-boot +++ b/compiler/prelude/TysWiredIn.hs-boot @@ -17,13 +17,12 @@ constraintKind :: Kind runtimeRepTyCon, vecCountTyCon, vecElemTyCon :: TyCon runtimeRepTy :: Type -ptrRepLiftedTy :: Type -ptrRepLiftedDataConTyCon, ptrRepUnliftedDataConTyCon, vecRepDataConTyCon :: TyCon +liftedRepDataConTyCon, vecRepDataConTyCon, tupleRepDataConTyCon :: TyCon -voidRepDataConTy, intRepDataConTy, +liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy, wordRepDataConTy, int64RepDataConTy, word64RepDataConTy, addrRepDataConTy, - floatRepDataConTy, doubleRepDataConTy, unboxedTupleRepDataConTy :: Type + floatRepDataConTy, doubleRepDataConTy :: Type vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, vec64DataConTy :: Type @@ -34,3 +33,5 @@ int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, doubleElemRepDataConTy :: Type anyTypeOfKind :: Kind -> Type +unboxedTupleKind :: [Type] -> Type +mkPromotedListTy :: Type -> [Type] -> Type diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs index 06ff71e54b..0b81f29a7d 100644 --- a/compiler/simplCore/SetLevels.hs +++ b/compiler/simplCore/SetLevels.hs @@ -65,6 +65,7 @@ module SetLevels ( import CoreSyn import CoreMonad ( FloatOutSwitches(..) ) import CoreUtils ( exprType + , isExprLevPoly , exprOkForSpeculation , collectMakeStaticArgs ) @@ -82,7 +83,6 @@ import Demand ( StrictSig, increaseStrictSigArity ) import Name ( getOccName, mkSystemVarName ) import OccName ( occNameString ) import Type ( isUnliftedType, Type, mkLamTypes, splitTyConApp_maybe ) -import Kind ( isLevityPolymorphic, typeKind ) import BasicTypes ( Arity, RecFlag(..) ) import DataCon ( dataConOrigResTy ) import TysWiredIn @@ -485,7 +485,7 @@ lvlMFE True env e@(_, AnnCase {}) lvlMFE strict_ctxt env ann_expr | floatTopLvlOnly env && not (isTopLvl dest_lvl) -- Only floating to the top level is allowed. - || isLevityPolymorphic (typeKind expr_ty) + || isExprLevPoly expr -- We can't let-bind levity polymorphic expressions -- See Note [Levity polymorphism invariants] in CoreSyn || notWorthFloating expr abs_vars diff --git a/compiler/simplCore/SimplEnv.hs b/compiler/simplCore/SimplEnv.hs index 59ac440230..8a26220029 100644 --- a/compiler/simplCore/SimplEnv.hs +++ b/compiler/simplCore/SimplEnv.hs @@ -691,7 +691,7 @@ substCo env co = Coercion.substCo (getTCvSubst env) co substIdType :: SimplEnv -> Id -> Id substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env }) id | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) - || isEmptyVarSet (tyCoVarsOfType old_ty) + || noFreeVarsOfType old_ty = id | otherwise = Id.setIdType id (Type.substTy (TCvSubst in_scope tv_env cv_env) old_ty) -- The tyCoVarsOfType is cheaper than it looks diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs index 4812e7eacb..bdc36345f7 100644 --- a/compiler/simplCore/SimplUtils.hs +++ b/compiler/simplCore/SimplUtils.hs @@ -450,15 +450,22 @@ mkArgInfo fun rules n_val_args call_cont -- add_type_str is done repeatedly (for each call); might be better -- once-for-all in the function -- But beware primops/datacons with no strictness - add_type_str _ [] = [] - add_type_str fun_ty strs -- Look through foralls - | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty -- Includes coercions - = add_type_str fun_ty' strs - add_type_str fun_ty (str:strs) -- Add strict-type info - | Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty - = (str || isStrictType arg_ty) : add_type_str fun_ty' strs - add_type_str _ strs - = strs + + add_type_str + = go + where + go _ [] = [] + go fun_ty strs -- Look through foralls + | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty -- Includes coercions + = go fun_ty' strs + go fun_ty (str:strs) -- Add strict-type info + | Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty + = (str || Just False == isLiftedType_maybe arg_ty) : go fun_ty' strs + -- If the type is levity-polymorphic, we can't know whether it's + -- strict. isLiftedType_maybe will return Just False only when + -- we're sure the type is unlifted. + go _ strs + = strs {- Note [Unsaturated functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs index fb31784e2d..2c8ff5e941 100644 --- a/compiler/simplCore/Simplify.hs +++ b/compiler/simplCore/Simplify.hs @@ -1157,6 +1157,10 @@ simplCast env body co0 cont0 addCoerce co (ApplyToVal { sc_arg = arg, sc_env = arg_se , sc_dup = dup, sc_cont = tail }) | Just (co1, co2) <- pushCoValArg co + , Pair _ new_ty <- coercionKind co1 + , not (isTypeLevPoly new_ty) -- without this check, we get a lev-poly arg + -- See Note [Levity polymorphism invariants] in CoreSyn + -- test: typecheck/should_run/EtaExpandLevPoly = do { (dup', arg_se', arg') <- simplArg env dup arg_se arg -- When we build the ApplyTo we can't mix the OutCoercion -- 'co' with the InExpr 'arg', so we simplify diff --git a/compiler/simplStg/RepType.hs b/compiler/simplStg/RepType.hs index 6309aecb3a..f59a8548f1 100644 --- a/compiler/simplStg/RepType.hs +++ b/compiler/simplStg/RepType.hs @@ -2,37 +2,40 @@ {-# LANGUAGE FlexibleContexts #-} module RepType - ( -- * Code generator views onto Types + ( + -- * Code generator views onto Types UnaryType, NvUnaryType, isNvUnaryType, - RepType(..), repType, repTypeArgs, isUnaryRep, isMultiRep, + unwrapType, -- * Predicates on types - isVoidTy, typePrimRep, + isVoidTy, -- * Type representation for the code generator - countConRepArgs, idFunRepArity, tyConPrimRep, + typePrimRep, typePrimRep1, + runtimeRepPrimRep, typePrimRepArgs, + PrimRep(..), primRepToType, + countFunRepArgs, countConRepArgs, tyConPrimRep, tyConPrimRep1, -- * Unboxed sum representation type - ubxSumRepType, layout, typeSlotTy, SlotTy (..), slotTyToType, - slotPrimRep, repTypeSlots + ubxSumRepType, layoutUbxSum, typeSlotTy, SlotTy (..), + slotPrimRep, primRepSlot ) where #include "HsVersions.h" import BasicTypes (Arity, RepArity) import DataCon -import Id import Outputable import PrelNames +import Coercion import TyCon import TyCoRep import Type -import TysPrim -import TysWiredIn import Util +import TysPrim +import {-# SOURCE #-} TysWiredIn ( anyTypeOfKind ) import Data.List (foldl', sort) -import Data.Maybe (maybeToList) import qualified Data.IntSet as IS {- ********************************************************************** @@ -49,101 +52,64 @@ type UnaryType = Type -- NvUnaryType : never an unboxed tuple or sum, or void -- -- UnaryType : never an unboxed tuple or sum; - -- can be Void# (but not (# #)) + -- can be Void# or (# #) isNvUnaryType :: Type -> Bool isNvUnaryType ty - = case repType ty of - UnaryRep _ -> True - MultiRep ss -> not (null ss) - -data RepType - = MultiRep [SlotTy] -- Represented by multiple values (e.g. unboxed tuple or sum) - | UnaryRep NvUnaryType -- Represented by a single value; but never Void#, or any - -- other zero-width type (isVoidTy) - -instance Outputable RepType where - ppr (MultiRep slots) = text "MultiRep" <+> ppr slots - ppr (UnaryRep ty) = text "UnaryRep" <+> ppr ty - -isMultiRep :: RepType -> Bool -isMultiRep (MultiRep _) = True -isMultiRep _ = False - -isUnaryRep :: RepType -> Bool -isUnaryRep (UnaryRep _) = True -isUnaryRep _ = False + | [_] <- typePrimRep ty + = True + | otherwise + = False -- INVARIANT: the result list is never empty. -repTypeArgs :: Type -> [UnaryType] -repTypeArgs ty = case repType ty of - MultiRep [] -> [voidPrimTy] - MultiRep slots -> map slotTyToType slots - UnaryRep ty -> [ty] - -repTypeSlots :: RepType -> [SlotTy] -repTypeSlots (MultiRep slots) = slots -repTypeSlots (UnaryRep ty) = maybeToList (typeSlotTy ty) - --- | 'repType' figure out how a type will be represented at runtime. It looks --- through --- --- 1. For-alls --- 2. Synonyms --- 3. Predicates --- 4. All newtypes, including recursive ones, but not newtype families --- 5. Casts --- -repType :: Type -> RepType -repType ty - = go initRecTc ty +typePrimRepArgs :: Type -> [PrimRep] +typePrimRepArgs ty + | [] <- reps + = [VoidRep] + | otherwise + = reps where - go :: RecTcChecker -> Type -> RepType - go rec_nts ty -- Expand predicates and synonyms - | Just ty' <- coreView ty - = go rec_nts ty' - - go rec_nts (ForAllTy _ ty2) -- Drop type foralls - = go rec_nts ty2 - - go rec_nts ty@(TyConApp tc tys) -- Expand newtypes - | isNewTyCon tc - , tys `lengthAtLeast` tyConArity tc - , Just rec_nts' <- checkRecTc rec_nts tc -- See Note [Expanding newtypes] in TyCon - = go rec_nts' (newTyConInstRhs tc tys) - - | isUnboxedTupleTyCon tc - = MultiRep (concatMap (repTypeSlots . go rec_nts) non_rr_tys) - - | isUnboxedSumTyCon tc - = MultiRep (ubxSumRepType non_rr_tys) - - | isVoidTy ty - = MultiRep [] - where - -- See Note [Unboxed tuple RuntimeRep vars] in TyCon - non_rr_tys = dropRuntimeRepArgs tys - - go rec_nts (CastTy ty _) - = go rec_nts ty - - go _ ty@(CoercionTy _) - = pprPanic "repType" (ppr ty) - - go _ ty = UnaryRep ty - - -idFunRepArity :: Id -> RepArity -idFunRepArity x = countFunRepArgs (idArity x) (idType x) + reps = typePrimRep ty + +-- | Gets rid of the stuff that prevents us from understanding the +-- runtime representation of a type. Including: +-- 1. Casts +-- 2. Newtypes +-- 3. Foralls +-- 4. Synonyms +-- But not type/data families, because we don't have the envs to hand. +unwrapType :: Type -> Type +unwrapType ty + | Just (_, unwrapped) + <- topNormaliseTypeX stepper mappend inner_ty + = unwrapped + | otherwise + = inner_ty + where + inner_ty = go ty + + go t | Just t' <- coreView t = go t' + go (ForAllTy _ t) = go t + go (CastTy t _) = go t + go t = t + + -- cf. Coercion.unwrapNewTypeStepper + stepper rec_nts tc tys + | Just (ty', _) <- instNewTyCon_maybe tc tys + = case checkRecTc rec_nts tc of + Just rec_nts' -> NS_Step rec_nts' (go ty') () + Nothing -> NS_Abort -- infinite newtypes + | otherwise + = NS_Done countFunRepArgs :: Arity -> Type -> RepArity countFunRepArgs 0 _ = 0 countFunRepArgs n ty - | UnaryRep (FunTy arg res) <- repType ty - = length (repTypeArgs arg) + countFunRepArgs (n - 1) res + | FunTy arg res <- unwrapType ty + = length (typePrimRepArgs arg) + countFunRepArgs (n - 1) res | otherwise - = pprPanic "countFunRepArgs: arity greater than type can handle" (ppr (n, ty, repType ty)) + = pprPanic "countFunRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty)) countConRepArgs :: DataCon -> RepArity countConRepArgs dc = go (dataConRepArity dc) (dataConRepType dc) @@ -152,14 +118,14 @@ countConRepArgs dc = go (dataConRepArity dc) (dataConRepType dc) go 0 _ = 0 go n ty - | UnaryRep (FunTy arg res) <- repType ty - = length (repTypeSlots (repType arg)) + go (n - 1) res + | FunTy arg res <- unwrapType ty + = length (typePrimRep arg) + go (n - 1) res | otherwise - = pprPanic "countConRepArgs: arity greater than type can handle" (ppr (n, ty, repType ty)) + = pprPanic "countConRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty)) -- | True if the type has zero width. isVoidTy :: Type -> Bool -isVoidTy ty = typePrimRep ty == VoidRep +isVoidTy = null . typePrimRep {- ********************************************************************** @@ -176,52 +142,59 @@ type SortedSlotTys = [SlotTy] -- -- E.g. -- --- (# Int | Maybe Int | (# Int, Bool #) #) +-- (# Int# | Maybe Int | (# Int#, Float# #) #) -- --- We call `ubxSumRepType [ Int, Maybe Int, (# Int,Bool #) ]`, --- which returns [Tag#, PtrSlot, PtrSlot] +-- We call `ubxSumRepType [ [IntRep], [LiftedRep], [IntRep, FloatRep] ]`, +-- which returns [WordSlot, PtrSlot, WordSlot, FloatSlot] -- -- INVARIANT: Result slots are sorted (via Ord SlotTy), except that at the head -- of the list we have the slot for the tag. -ubxSumRepType :: [Type] -> [SlotTy] -ubxSumRepType constrs0 = - ASSERT2( length constrs0 > 1, ppr constrs0 ) -- otherwise it isn't a sum type - let - combine_alts :: [SortedSlotTys] -- slots of constructors - -> SortedSlotTys -- final slots - combine_alts constrs = foldl' merge [] constrs - - merge :: SortedSlotTys -> SortedSlotTys -> SortedSlotTys - merge existing_slots [] - = existing_slots - merge [] needed_slots - = needed_slots - merge (es : ess) (s : ss) - | Just s' <- s `fitsIn` es - = -- found a slot, use it - s' : merge ess ss - | s < es - = -- we need a new slot and this is the right place for it - s : merge (es : ess) ss - | otherwise - = -- keep searching for a slot - es : merge ess (s : ss) - - -- Nesting unboxed tuples and sums is OK, so we need to flatten first. - rep :: Type -> SortedSlotTys - rep ty = sort (repTypeSlots (repType ty)) - - sumRep = WordSlot : combine_alts (map rep constrs0) - -- WordSlot: for the tag of the sum - in - sumRep - -layout :: SortedSlotTys -- Layout of sum. Does not include tag. - -- We assume that they are in increasing order - -> [SlotTy] -- Slot types of things we want to map to locations in the - -- sum layout - -> [Int] -- Where to map 'things' in the sum layout -layout sum_slots0 arg_slots0 = +ubxSumRepType :: [[PrimRep]] -> [SlotTy] +ubxSumRepType constrs0 + -- These first two cases never classify an actual unboxed sum, which always + -- has at least two disjuncts. But it could happen if a user writes, e.g., + -- forall (a :: TYPE (SumRep [IntRep])). ... + -- which could never be instantiated. We still don't want to panic. + | length constrs0 < 2 + = [WordSlot] + + | otherwise + = let + combine_alts :: [SortedSlotTys] -- slots of constructors + -> SortedSlotTys -- final slots + combine_alts constrs = foldl' merge [] constrs + + merge :: SortedSlotTys -> SortedSlotTys -> SortedSlotTys + merge existing_slots [] + = existing_slots + merge [] needed_slots + = needed_slots + merge (es : ess) (s : ss) + | Just s' <- s `fitsIn` es + = -- found a slot, use it + s' : merge ess ss + | s < es + = -- we need a new slot and this is the right place for it + s : merge (es : ess) ss + | otherwise + = -- keep searching for a slot + es : merge ess (s : ss) + + -- Nesting unboxed tuples and sums is OK, so we need to flatten first. + rep :: [PrimRep] -> SortedSlotTys + rep ty = sort (map primRepSlot ty) + + sumRep = WordSlot : combine_alts (map rep constrs0) + -- WordSlot: for the tag of the sum + in + sumRep + +layoutUbxSum :: SortedSlotTys -- Layout of sum. Does not include tag. + -- We assume that they are in increasing order + -> [SlotTy] -- Slot types of things we want to map to locations in the + -- sum layout + -> [Int] -- Where to map 'things' in the sum layout +layoutUbxSum sum_slots0 arg_slots0 = go arg_slots0 IS.empty where go :: [SlotTy] -> IS.IntSet -> [Int] @@ -273,11 +246,12 @@ typeSlotTy ty | isVoidTy ty = Nothing | otherwise - = Just (primRepSlot (typePrimRep ty)) + = Just (primRepSlot (typePrimRep1 ty)) primRepSlot :: PrimRep -> SlotTy primRepSlot VoidRep = pprPanic "primRepSlot" (text "No slot for VoidRep") -primRepSlot PtrRep = PtrSlot +primRepSlot LiftedRep = PtrSlot +primRepSlot UnliftedRep = PtrSlot primRepSlot IntRep = WordSlot primRepSlot WordRep = WordSlot primRepSlot Int64Rep = Word64Slot @@ -287,16 +261,8 @@ primRepSlot FloatRep = FloatSlot primRepSlot DoubleRep = DoubleSlot primRepSlot VecRep{} = pprPanic "primRepSlot" (text "No slot for VecRep") --- Used when unarising sum binders (need to give unarised Ids types) -slotTyToType :: SlotTy -> Type -slotTyToType PtrSlot = anyTypeOfKind liftedTypeKind -slotTyToType Word64Slot = int64PrimTy -slotTyToType WordSlot = intPrimTy -slotTyToType DoubleSlot = doublePrimTy -slotTyToType FloatSlot = floatPrimTy - slotPrimRep :: SlotTy -> PrimRep -slotPrimRep PtrSlot = PtrRep +slotPrimRep PtrSlot = LiftedRep -- choice between lifted & unlifted seems arbitrary slotPrimRep Word64Slot = Word64Rep slotPrimRep WordSlot = WordRep slotPrimRep DoubleSlot = DoubleRep @@ -332,41 +298,68 @@ fitsIn ty1 ty2 * * ********************************************************************** -} --- | Discovers the primitive representation of a more abstract 'UnaryType' -typePrimRep :: HasDebugCallStack => UnaryType -> PrimRep -typePrimRep ty = kindPrimRep (text "kindRep ty" <+> ppr ty $$ ppr (typeKind ty)) +-- | Discovers the primitive representation of a 'Type'. Returns +-- a list of 'PrimRep': it's a list because of the possibility of +-- no runtime representation (void) or multiple (unboxed tuple/sum) +typePrimRep :: HasDebugCallStack => Type -> [PrimRep] +typePrimRep ty = kindPrimRep (text "typePrimRep" <+> + parens (ppr ty <+> dcolon <+> ppr (typeKind ty))) (typeKind ty) +-- | Like 'typePrimRep', but assumes that there is precisely one 'PrimRep' output; +-- an empty list of PrimReps becomes a VoidRep +typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimRep +typePrimRep1 ty = case typePrimRep ty of + [] -> VoidRep + [rep] -> rep + _ -> pprPanic "typePrimRep1" (ppr ty $$ ppr (typePrimRep ty)) + -- | Find the runtime representation of a 'TyCon'. Defined here to --- avoid module loops. Do not call this on unboxed tuples or sums, --- because they don't /have/ a runtime representation -tyConPrimRep :: HasDebugCallStack => TyCon -> PrimRep +-- avoid module loops. Returns a list of the register shapes necessary. +tyConPrimRep :: HasDebugCallStack => TyCon -> [PrimRep] tyConPrimRep tc - = ASSERT2( not (isUnboxedTupleTyCon tc), ppr tc ) - ASSERT2( not (isUnboxedSumTyCon tc), ppr tc ) - kindPrimRep (text "kindRep tc" <+> ppr tc $$ ppr res_kind) + = kindPrimRep (text "kindRep tc" <+> ppr tc $$ ppr res_kind) res_kind where res_kind = tyConResKind tc --- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep' +-- | Like 'tyConPrimRep', but assumed that there is precisely zero or +-- one 'PrimRep' output +tyConPrimRep1 :: HasDebugCallStack => TyCon -> PrimRep +tyConPrimRep1 tc = case tyConPrimRep tc of + [] -> VoidRep + [rep] -> rep + _ -> pprPanic "tyConPrimRep1" (ppr tc $$ ppr (tyConPrimRep tc)) + +-- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's -- of values of types of this kind. -kindPrimRep :: HasDebugCallStack => SDoc -> Kind -> PrimRep +kindPrimRep :: HasDebugCallStack => SDoc -> Kind -> [PrimRep] kindPrimRep doc ki | Just ki' <- coreViewOneStarKind ki = kindPrimRep doc ki' -kindPrimRep _ (TyConApp typ [runtime_rep]) +kindPrimRep doc (TyConApp typ [runtime_rep]) = ASSERT( typ `hasKey` tYPETyConKey ) - go runtime_rep - where - go rr - | Just rr' <- coreView rr - = go rr' - go (TyConApp rr_dc args) - | RuntimeRep fun <- tyConRuntimeRepInfo rr_dc - = fun args - go rr - = pprPanic "kindPrimRep.go" (ppr rr) + runtimeRepPrimRep doc runtime_rep kindPrimRep doc ki - = WARN( True, text "kindPrimRep defaulting to PtrRep on" <+> ppr ki $$ doc ) - PtrRep -- this can happen legitimately for, e.g., Any + = pprPanic "kindPrimRep" (ppr ki $$ doc) + + -- TODO (RAE): Remove: + -- WARN( True, text "kindPrimRep defaulting to LiftedRep on" <+> ppr ki $$ doc ) + -- [LiftedRep] -- this can happen legitimately for, e.g., Any + +-- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that +-- it encodes. +runtimeRepPrimRep :: HasDebugCallStack => SDoc -> Type -> [PrimRep] +runtimeRepPrimRep doc rr_ty + | Just rr_ty' <- coreView rr_ty + = runtimeRepPrimRep doc rr_ty' + | TyConApp rr_dc args <- rr_ty + , RuntimeRep fun <- tyConRuntimeRepInfo rr_dc + = fun args + | otherwise + = pprPanic "runtimeRepPrimRep" (doc $$ ppr rr_ty) + +-- | Convert a PrimRep back to a Type. Used only in the unariser to give types +-- to fresh Ids. Really, only the type's representation matters. +primRepToType :: PrimRep -> Type +primRepToType = anyTypeOfKind . tYPE . primRepToRuntimeRep diff --git a/compiler/simplStg/UnariseStg.hs b/compiler/simplStg/UnariseStg.hs index e8ba200d0a..aa42586cd1 100644 --- a/compiler/simplStg/UnariseStg.hs +++ b/compiler/simplStg/UnariseStg.hs @@ -209,7 +209,7 @@ import Outputable import RepType import StgSyn import Type -import TysPrim (intPrimTyCon, intPrimTy) +import TysPrim (intPrimTy) import TysWiredIn import UniqSupply import Util @@ -225,7 +225,7 @@ import qualified Data.IntMap as IM -- -- x :-> MultiVal [a,b,c] in rho -- --- iff x's repType is a MultiRep, or equivalently +-- iff x's typePrimRep is not a singleton, or equivalently -- x's type is an unboxed tuple, sum or void. -- -- x :-> UnaryVal x' @@ -487,24 +487,24 @@ mapTupleIdBinders mapTupleIdBinders ids args0 rho0 = ASSERT(not (any (isVoidTy . stgArgType) args0)) let - ids_unarised :: [(Id, RepType)] - ids_unarised = map (\id -> (id, repType (idType id))) ids + ids_unarised :: [(Id, [PrimRep])] + ids_unarised = map (\id -> (id, typePrimRep (idType id))) ids - map_ids :: UnariseEnv -> [(Id, RepType)] -> [StgArg] -> UnariseEnv + map_ids :: UnariseEnv -> [(Id, [PrimRep])] -> [StgArg] -> UnariseEnv map_ids rho [] _ = rho - map_ids rho ((x, x_rep) : xs) args = + map_ids rho ((x, x_reps) : xs) args = let - x_arity = length (repTypeSlots x_rep) + x_arity = length x_reps (x_args, args') = ASSERT(args `lengthAtLeast` x_arity) splitAt x_arity args rho' - | isMultiRep x_rep - = extendRho rho x (MultiVal x_args) - | otherwise + | x_arity == 1 = ASSERT(x_args `lengthIs` 1) extendRho rho x (UnaryVal (head x_args)) + | otherwise + = extendRho rho x (MultiVal x_args) in map_ids rho' xs args' in @@ -521,9 +521,9 @@ mapSumIdBinders mapSumIdBinders [id] args rho0 = ASSERT(not (any (isVoidTy . stgArgType) args)) let - arg_slots = concatMap (repTypeSlots . repType . stgArgType) args - id_slots = repTypeSlots (repType (idType id)) - layout1 = layout arg_slots id_slots + arg_slots = map primRepSlot $ concatMap (typePrimRep . stgArgType) args + id_slots = map primRepSlot $ typePrimRep (idType id) + layout1 = layoutUbxSum arg_slots id_slots in if isMultiValBndr id then extendRho rho0 id (MultiVal [ args !! i | i <- layout1 ]) @@ -550,12 +550,12 @@ mkUbxSum -> [OutStgArg] -- Final tuple arguments mkUbxSum dc ty_args args0 = let - (_ : sum_slots) = ubxSumRepType ty_args + (_ : sum_slots) = ubxSumRepType (map typePrimRep ty_args) -- drop tag slot tag = dataConTag dc - layout' = layout sum_slots (mapMaybe (typeSlotTy . stgArgType) args0) + layout' = layoutUbxSum sum_slots (mapMaybe (typeSlotTy . stgArgType) args0) tag_arg = StgLitArg (MachInt (fromIntegral tag)) arg_idxs = IM.fromList (zipEqual "mkUbxSum" layout' args0) @@ -656,12 +656,12 @@ unariseFunArgBinders rho xs = second concat <$> mapAccumLM unariseFunArgBinder r unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id]) -- Result list of binders is never empty unariseFunArgBinder rho x = - case repType (idType x) of - UnaryRep _ -> return (rho, [x]) - MultiRep [] -> return (extendRho rho x (MultiVal []), [voidArgId]) - -- NB: do not remove void binders - MultiRep slots -> do - xs <- mkIds (mkFastString "us") (map slotTyToType slots) + case typePrimRep (idType x) of + [] -> return (extendRho rho x (MultiVal []), [voidArgId]) + -- NB: do not remove void binders + [_] -> return (rho, [x]) + reps -> do + xs <- mkIds (mkFastString "us") (map primRepToType reps) return (extendRho rho x (MultiVal (map StgVarArg xs)), xs) -------------------------------------------------------------------------------- @@ -687,10 +687,10 @@ unariseConArgBinders rho xs = second concat <$> mapAccumLM unariseConArgBinder r unariseConArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id]) unariseConArgBinder rho x = - case repType (idType x) of - UnaryRep _ -> return (rho, [x]) - MultiRep slots -> do - xs <- mkIds (mkFastString "us") (map slotTyToType slots) + case typePrimRep (idType x) of + [_] -> return (rho, [x]) + reps -> do + xs <- mkIds (mkFastString "us") (map primRepToType reps) return (extendRho rho x (MultiVal (map StgVarArg xs)), xs) unariseFreeVars :: UnariseEnv -> [InId] -> [OutId] @@ -720,7 +720,11 @@ mkId :: FastString -> UnaryType -> UniqSM Id mkId = mkSysLocalOrCoVarM isMultiValBndr :: Id -> Bool -isMultiValBndr = isMultiRep . repType . idType +isMultiValBndr id + | [_] <- typePrimRep (idType id) + = False + | otherwise + = True isUnboxedSumBndr :: Id -> Bool isUnboxedSumBndr = isUnboxedSumType . idType @@ -732,7 +736,7 @@ mkTuple :: [StgArg] -> StgExpr mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) args (map stgArgType args) tagAltTy :: AltType -tagAltTy = PrimAlt intPrimTyCon +tagAltTy = PrimAlt IntRep tagTy :: Type tagTy = intPrimTy diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs index 5531d31d30..dcb923afea 100644 --- a/compiler/stgSyn/CoreToStg.hs +++ b/compiler/stgSyn/CoreToStg.hs @@ -472,16 +472,25 @@ coreToStgExpr (Let bind body) = do coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e) mkStgAltType :: Id -> [CoreAlt] -> AltType -mkStgAltType bndr alts = case repType (idType bndr) of - UnaryRep rep_ty -> case tyConAppTyCon_maybe rep_ty of - Just tc | isUnliftedTyCon tc -> PrimAlt tc - | isAbstractTyCon tc -> look_for_better_tycon - | isAlgTyCon tc -> AlgAlt tc - | otherwise -> ASSERT2( _is_poly_alt_tycon tc, ppr tc ) - PolyAlt - Nothing -> PolyAlt - MultiRep slots -> MultiValAlt (length slots) +mkStgAltType bndr alts + | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty + = MultiValAlt (length prim_reps) -- always use MultiValAlt for unboxed tuples + + | otherwise + = case prim_reps of + [LiftedRep] -> case tyConAppTyCon_maybe (unwrapType bndr_ty) of + Just tc + | isAbstractTyCon tc -> look_for_better_tycon + | isAlgTyCon tc -> AlgAlt tc + | otherwise -> ASSERT2( _is_poly_alt_tycon tc, ppr tc ) + PolyAlt + Nothing -> PolyAlt + [unlifted] -> PrimAlt unlifted + not_unary -> MultiValAlt (length not_unary) where + bndr_ty = idType bndr + prim_reps = typePrimRep bndr_ty + _is_poly_alt_tycon tc = isFunTyCon tc || isPrimTyCon tc -- "Any" is lifted but primitive @@ -650,8 +659,7 @@ coreToStgArgs (arg : args) = do -- Non-type argument arg_ty = exprType arg stg_arg_ty = stgArgType stg_arg bad_args = (isUnliftedType arg_ty && not (isUnliftedType stg_arg_ty)) - || (map typePrimRep (repTypeArgs arg_ty) - /= map typePrimRep (repTypeArgs stg_arg_ty)) + || (typePrimRep arg_ty /= typePrimRep stg_arg_ty) -- In GHCi we coerce an argument of type BCO# (unlifted) to HValue (lifted), -- and pass it to a function expecting an HValue (arg_ty). This is ok because -- we can treat an unlifted value as lifted. But the other way round @@ -802,7 +810,8 @@ mkStgRhs' con_updateable rhs_fvs bndr binder_info rhs | StgConApp con args _ <- unticked_rhs , not (con_updateable con args) = -- CorePrep does this right, but just to make sure - ASSERT(not (isUnboxedTupleCon con || isUnboxedSumCon con)) + ASSERT2( not (isUnboxedTupleCon con || isUnboxedSumCon con) + , ppr bndr $$ ppr con $$ ppr args) StgRhsCon noCCS con args | otherwise = StgRhsClosure noCCS binder_info diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs index 0dba8d8359..e31e7ae015 100644 --- a/compiler/stgSyn/StgLint.hs +++ b/compiler/stgSyn/StgLint.hs @@ -196,21 +196,19 @@ lintStgExpr (StgCase scrut bndr alts_type alts) = runMaybeT $ do in_scope <- MaybeT $ liftM Just $ case alts_type of - AlgAlt tc -> check_bndr tc >> return True - PrimAlt tc -> check_bndr tc >> return True + AlgAlt tc -> check_bndr (tyConPrimRep tc) >> return True + PrimAlt rep -> check_bndr [rep] >> return True MultiValAlt _ -> return False -- Binder is always dead in this case PolyAlt -> return True MaybeT $ addInScopeVars [bndr | in_scope] $ lintStgAlts alts scrut_ty where - scrut_ty = idType bndr - UnaryRep scrut_rep = repType scrut_ty -- Not used if scrutinee is unboxed tuple or sum - check_bndr tc = case tyConAppTyCon_maybe scrut_rep of - Just bndr_tc -> checkL (tc == bndr_tc) bad_bndr - Nothing -> addErrL bad_bndr + scrut_ty = idType bndr + scrut_reps = typePrimRep scrut_ty + check_bndr reps = checkL (scrut_reps == reps) bad_bndr where - bad_bndr = mkDefltMsg bndr tc + bad_bndr = mkDefltMsg bndr reps lintStgAlts :: [StgAlt] -> Type -- Type of scrutinee @@ -418,20 +416,18 @@ stgEqType :: Type -> Type -> Bool -- Fundamentally this is a losing battle because of unsafeCoerce stgEqType orig_ty1 orig_ty2 - = gos (repType orig_ty1) (repType orig_ty2) + = gos (typePrimRep orig_ty1) (typePrimRep orig_ty2) where - gos :: RepType -> RepType -> Bool - gos (MultiRep slots1) (MultiRep slots2) - = slots1 == slots2 - gos (UnaryRep ty1) (UnaryRep ty2) = go ty1 ty2 - gos _ _ = False + gos :: [PrimRep] -> [PrimRep] -> Bool + gos [_] [_] = go orig_ty1 orig_ty2 + gos reps1 reps2 = reps1 == reps2 go :: UnaryType -> UnaryType -> Bool go ty1 ty2 | Just (tc1, tc_args1) <- splitTyConApp_maybe ty1 , Just (tc2, tc_args2) <- splitTyConApp_maybe ty2 , let res = if tc1 == tc2 - then equalLength tc_args1 tc_args2 && and (zipWith (gos `on` repType) tc_args1 tc_args2) + then equalLength tc_args1 tc_args2 && and (zipWith (gos `on` typePrimRep) tc_args1 tc_args2) else -- TyCons don't match; but don't bleat if either is a -- family TyCon because a coercion might have made it -- equal to something else @@ -462,10 +458,10 @@ _mkCaseAltMsg _alts = ($$) (text "In some case alternatives, type of alternatives not all same:") (Outputable.empty) -- LATER: ppr alts -mkDefltMsg :: Id -> TyCon -> MsgDoc -mkDefltMsg bndr tc - = ($$) (text "Binder of a case expression doesn't match type of scrutinee:") - (ppr bndr $$ ppr (idType bndr) $$ ppr tc) +mkDefltMsg :: Id -> [PrimRep] -> MsgDoc +mkDefltMsg bndr reps + = ($$) (text "Binder of a case expression doesn't match representation of scrutinee:") + (ppr bndr $$ ppr (idType bndr) $$ ppr reps) mkFunAppMsg :: Type -> [Type] -> StgExpr -> MsgDoc mkFunAppMsg fun_ty arg_tys expr diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs index 64c8448421..48e836cc56 100644 --- a/compiler/stgSyn/StgSyn.hs +++ b/compiler/stgSyn/StgSyn.hs @@ -62,7 +62,7 @@ import PprCore ( {- instances -} ) import PrimOp ( PrimOp, PrimCall ) import TyCon ( PrimRep(..), TyCon ) import Type ( Type ) -import RepType ( typePrimRep ) +import RepType ( typePrimRep1 ) import Unique ( Unique ) import Util @@ -104,10 +104,10 @@ isDllConApp dflags this_mod con args = isDllName dflags this_mod (dataConName con) || any is_dll_arg args | otherwise = False where - -- NB: typePrimRep is legit because any free variables won't have + -- NB: typePrimRep1 is legit because any free variables won't have -- unlifted type (there are no unlifted things at top level) is_dll_arg :: StgArg -> Bool - is_dll_arg (StgVarArg v) = isAddrRep (typePrimRep (idType v)) + is_dll_arg (StgVarArg v) = isAddrRep (typePrimRep1 (idType v)) && isDllName dflags this_mod (idName v) is_dll_arg _ = False @@ -124,9 +124,10 @@ isDllConApp dflags this_mod con args -- $WT1 = T1 Int (Coercion (Refl Int)) -- The coercion argument here gets VoidRep isAddrRep :: PrimRep -> Bool -isAddrRep AddrRep = True -isAddrRep PtrRep = True -isAddrRep _ = False +isAddrRep AddrRep = True +isAddrRep LiftedRep = True +isAddrRep UnliftedRep = True +isAddrRep _ = False -- | Type of an @StgArg@ -- @@ -533,10 +534,11 @@ type GenStgAlt bndr occ GenStgExpr bndr occ) -- ...right-hand side. data AltType - = PolyAlt -- Polymorphic (a type variable) + = PolyAlt -- Polymorphic (a lifted type variable) | MultiValAlt Int -- Multi value of this arity (unboxed tuple or sum) + -- the arity could indeed be 1 for unary unboxed tuple | AlgAlt TyCon -- Algebraic data type; the AltCons will be DataAlts - | PrimAlt TyCon -- Primitive data type; the AltCons will be LitAlts + | PrimAlt PrimRep -- Primitive data type; the AltCons (if any) will be LitAlts {- ************************************************************************ diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index 2206480585..2ad00d50e3 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -9,7 +9,7 @@ {-# LANGUAGE FlexibleContexts #-} module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds, - tcValBinds, tcHsBootSigs, tcPolyCheck, + tcHsBootSigs, tcPolyCheck, tcVectDecls, addTypecheckedBinds, chooseInferredQuantifiers, badBootDeclErr ) where @@ -57,7 +57,7 @@ import Maybes import Util import BasicTypes import Outputable -import PrelNames( gHC_PRIM, ipClassName ) +import PrelNames( ipClassName ) import TcValidity (checkValidType) import Unique (getUnique) import UniqFM @@ -399,7 +399,7 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside tc_scc (CyclicSCC binds) = tc_sub_group Recursive binds tc_sub_group rec_tc binds = - tcPolyBinds top_lvl sig_fn prag_fn Recursive rec_tc closed binds + tcPolyBinds sig_fn prag_fn Recursive rec_tc closed binds recursivePatSynErr :: OutputableBndr name => LHsBinds name -> TcM a recursivePatSynErr binds @@ -430,7 +430,7 @@ tc_single _top_lvl sig_fn _prag_fn Just _ -> panic "tc_single" tc_single top_lvl sig_fn prag_fn lbind closed thing_inside - = do { (binds1, ids) <- tcPolyBinds top_lvl sig_fn prag_fn + = do { (binds1, ids) <- tcPolyBinds sig_fn prag_fn NonRecursive NonRecursive closed [lbind] @@ -461,7 +461,7 @@ mkEdges sig_fn binds , bndr <- collectHsBindBinders bind ] ------------------------ -tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragEnv +tcPolyBinds :: TcSigFun -> TcPragEnv -> RecFlag -- Whether the group is really recursive -> RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures @@ -480,7 +480,7 @@ tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragEnv -- Knows nothing about the scope of the bindings -- None of the bindings are pattern synonyms -tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc closed bind_list +tcPolyBinds sig_fn prag_fn rec_group rec_tc closed bind_list = setSrcSpan loc $ recoverM (recoveryCode binder_names sig_fn) $ do -- Set up main recover; take advantage of any type sigs @@ -490,15 +490,11 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc closed bind_list ; dflags <- getDynFlags ; let plan = decideGeneralisationPlan dflags bind_list closed sig_fn ; traceTc "Generalisation plan" (ppr plan) - ; result@(tc_binds, poly_ids) <- case plan of + ; result@(_, poly_ids) <- case plan of NoGen -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list InferGen mn -> tcPolyInfer rec_tc prag_fn sig_fn mn bind_list CheckGen lbind sig -> tcPolyCheck prag_fn sig lbind - -- Check whether strict bindings are ok - -- These must be non-recursive etc, and are not generalised - -- They desugar to a case expression in the end - ; checkStrictBinds top_lvl rec_group bind_list tc_binds poly_ids ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group , vcat [ppr id <+> ppr (idType id) | id <- poly_ids] ]) @@ -552,11 +548,8 @@ tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list ; return (binds', mono_ids') } where tc_mono_info (MBI { mbi_poly_name = name, mbi_mono_id = mono_id }) - = do { mono_ty' <- zonkTcType (idType mono_id) - -- Zonk, mainly to expose unboxed types to checkStrictBinds - ; let mono_id' = setIdType mono_id mono_ty' - ; _specs <- tcSpecPrags mono_id' (lookupPragEnv prag_fn name) - ; return mono_id' } + = do { _specs <- tcSpecPrags mono_id (lookupPragEnv prag_fn name) + ; return mono_id } -- NB: tcPrags generates error messages for -- specialisation pragmas for non-overloaded sigs -- Indeed that is why we call it here! @@ -1499,7 +1492,6 @@ decideGeneralisationPlan :: DynFlags -> [LHsBind Name] -> IsGroupClosed -> TcSigFun -> GeneralisationPlan decideGeneralisationPlan dflags lbinds closed sig_fn - | unlifted_pat_binds = NoGen | has_partial_sigs = InferGen (and partial_sig_mrs) | Just (bind, sig) <- one_funbind_with_sig = CheckGen bind sig | mono_local_binds closed = NoGen @@ -1519,10 +1511,6 @@ decideGeneralisationPlan dflags lbinds closed sig_fn , let (_, L _ theta, _) = splitLHsSigmaTy (hsSigWcType hs_ty) ] has_partial_sigs = not (null partial_sig_mrs) - unlifted_pat_binds = any isUnliftedHsBind binds - -- Unlifted patterns (unboxed tuple) must not - -- be polymorphic, because we are going to force them - -- See Trac #4498, #8762 mono_restriction = xopt LangExt.MonomorphismRestriction dflags && any restricted binds @@ -1594,107 +1582,6 @@ isClosedBndrGroup binds = do -- These won't be in the local type env. -- Ditto class method etc from the current module -------------------- -checkStrictBinds :: TopLevelFlag -> RecFlag - -> [LHsBind Name] - -> LHsBinds TcId -> [Id] - -> TcM () --- Check that non-overloaded unlifted bindings are --- a) non-recursive, --- b) not top level, --- c) not a multiple-binding group (more or less implied by (a)) - -checkStrictBinds top_lvl rec_group orig_binds tc_binds poly_ids - | any_unlifted_bndr || any_strict_pat -- This binding group must be matched strictly - = do { check (isNotTopLevel top_lvl) - (strictBindErr "Top-level" any_unlifted_bndr orig_binds) - ; check (isNonRec rec_group) - (strictBindErr "Recursive" any_unlifted_bndr orig_binds) - - ; check (all is_monomorphic (bagToList tc_binds)) - (polyBindErr orig_binds) - -- data Ptr a = Ptr Addr# - -- f x = let p@(Ptr y) = ... in ... - -- Here the binding for 'p' is polymorphic, but does - -- not mix with an unlifted binding for 'y'. You should - -- use a bang pattern. Trac #6078. - - ; check (isSingleton orig_binds) - (strictBindErr "Multiple" any_unlifted_bndr orig_binds) - - -- Complain about a binding that looks lazy - -- e.g. let I# y = x in ... - -- Remember, in checkStrictBinds we are going to do strict - -- matching, so (for software engineering reasons) we insist - -- that the strictness is manifest on each binding - -- However, lone (unboxed) variables are ok - ; check (not any_pat_looks_lazy) - (unliftedMustBeBang orig_binds) } - | otherwise - = traceTc "csb2" (ppr [(id, idType id) | id <- poly_ids]) >> - return () - where - any_unlifted_bndr = any is_unlifted poly_ids - any_strict_pat = any (isUnliftedHsBind . unLoc) orig_binds - any_pat_looks_lazy = any (looksLazyPatBind . unLoc) orig_binds - - is_unlifted id = case tcSplitSigmaTy (idType id) of - (_, _, rho) -> isUnliftedType rho - -- For the is_unlifted check, we need to look inside polymorphism - -- and overloading. E.g. x = (# 1, True #) - -- would get type forall a. Num a => (# a, Bool #) - -- and we want to reject that. See Trac #9140 - - is_monomorphic (L _ (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs })) - = null tvs && null evs - is_monomorphic (L _ (AbsBindsSig { abs_tvs = tvs, abs_ev_vars = evs })) - = null tvs && null evs - is_monomorphic _ = True - - check :: Bool -> MsgDoc -> TcM () - -- Just like checkTc, but with a special case for module GHC.Prim: - -- see Note [Compiling GHC.Prim] - check True _ = return () - check False err = do { mod <- getModule - ; checkTc (mod == gHC_PRIM) err } - -unliftedMustBeBang :: [LHsBind Name] -> SDoc -unliftedMustBeBang binds - = hang (text "Pattern bindings containing unlifted types should use an outermost bang pattern:") - 2 (vcat (map ppr binds)) - -polyBindErr :: [LHsBind Name] -> SDoc -polyBindErr binds - = hang (text "You can't mix polymorphic and unlifted bindings") - 2 (vcat [vcat (map ppr binds), - text "Probable fix: add a type signature"]) - -strictBindErr :: String -> Bool -> [LHsBind Name] -> SDoc -strictBindErr flavour any_unlifted_bndr binds - = hang (text flavour <+> msg <+> text "aren't allowed:") - 2 (vcat (map ppr binds)) - where - msg | any_unlifted_bndr = text "bindings for unlifted types" - | otherwise = text "bang-pattern or unboxed-tuple bindings" - - -{- Note [Compiling GHC.Prim] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Module GHC.Prim has no source code: it is the host module for -primitive, built-in functions and types. However, for Haddock-ing -purposes we generate (via utils/genprimopcode) a fake source file -GHC/Prim.hs, and give it to Haddock, so that it can generate -documentation. It contains definitions like - nullAddr# :: NullAddr# -which would normally be rejected as a top-level unlifted binding. But -we don't want to complain, because we are only "compiling" this fake -mdule for documentation purposes. Hence this hacky test for gHC_PRIM -in checkStrictBinds. - -(We only make the test if things look wrong, so there is no cost in -the common case.) -} - - {- ********************************************************************* * * Error contexts and messages @@ -1707,4 +1594,3 @@ patMonoBindsCtxt :: (OutputableBndrId id, Outputable body) => LPat id -> GRHSs Name body -> SDoc patMonoBindsCtxt pat grhss = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss) - diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs index 7f5ea9aaa8..671cb132bf 100644 --- a/compiler/typecheck/TcCanonical.hs +++ b/compiler/typecheck/TcCanonical.hs @@ -25,7 +25,6 @@ import FamInst ( tcTopNormaliseNewTypeTF_maybe ) import Var import Outputable import DynFlags( DynFlags ) -import VarSet import NameSet import RdrName @@ -461,7 +460,7 @@ mk_strict_superclasses rec_clss ev cls tys (mkEvScSelectors (EvId evar) cls tys) ; concatMapM (mk_superclasses rec_clss) sc_evs } - | isEmptyVarSet (tyCoVarsOfTypes tys) + | all noFreeVarsOfType tys = return [] -- Wanteds with no variables yield no deriveds. -- See Note [Improvement from Ground Wanteds] diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs index 6135800752..7b19cd0311 100644 --- a/compiler/typecheck/TcEnv.hs +++ b/compiler/typecheck/TcEnv.hs @@ -410,9 +410,7 @@ tcExtendTyVarEnv2 binds thing_inside isTypeClosedLetBndr :: Id -> Bool -- See Note [Bindings with closed types] in TcRnTypes -isTypeClosedLetBndr id - | isEmptyVarSet (tyCoVarsOfType (idType id)) = True - | otherwise = False +isTypeClosedLetBndr = noFreeVarsOfType . idType tcExtendLetEnv :: TopLevelFlag -> IsGroupClosed -> [TcId] -> TcM a -> TcM a -- Used for both top-level value bindings and and nested let/where-bindings diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index 639134e988..bb591c8e01 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -33,8 +33,7 @@ import HsBinds ( PatSynBind(..) ) import Name import RdrName ( lookupGlobalRdrEnv, lookupGRE_Name, GlobalRdrEnv , mkRdrUnqual, isLocalGRE, greSrcSpan ) -import PrelNames ( typeableClassName, hasKey, ptrRepLiftedDataConKey - , ptrRepUnliftedDataConKey ) +import PrelNames ( typeableClassName, hasKey, liftedRepDataConKey ) import Id import Var import VarSet @@ -1464,7 +1463,7 @@ mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2 extra2 = important $ mkEqInfoMsg ct ty1 ty2 interesting_tyvars - = filter (not . isEmptyVarSet . tyCoVarsOfType . tyVarKind) $ + = filter (not . noFreeVarsOfType . tyVarKind) $ filter isTyVar $ fvVarList $ tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2 @@ -1689,20 +1688,14 @@ misMatchMsg ct oriented ty1 ty2 = misMatchMsg ct (Just IsSwapped) ty2 ty1 -- These next two cases are when we're about to report, e.g., that - -- 'PtrRepLifted doesn't match 'VoidRep. Much better just to say + -- 'LiftedRep doesn't match 'VoidRep. Much better just to say -- lifted vs. unlifted | Just (tc1, []) <- splitTyConApp_maybe ty1 - , tc1 `hasKey` ptrRepLiftedDataConKey + , tc1 `hasKey` liftedRepDataConKey = lifted_vs_unlifted | Just (tc2, []) <- splitTyConApp_maybe ty2 - , tc2 `hasKey` ptrRepLiftedDataConKey - = lifted_vs_unlifted - - | Just (tc1, []) <- splitTyConApp_maybe ty1 - , Just (tc2, []) <- splitTyConApp_maybe ty2 - , (tc1 `hasKey` ptrRepLiftedDataConKey && tc2 `hasKey` ptrRepUnliftedDataConKey) - || (tc1 `hasKey` ptrRepUnliftedDataConKey && tc2 `hasKey` ptrRepLiftedDataConKey) + , tc2 `hasKey` liftedRepDataConKey = lifted_vs_unlifted | otherwise -- So now we have Nothing or (Just IsSwapped) diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs index 6055f018be..60a838bf78 100644 --- a/compiler/typecheck/TcEvidence.hs +++ b/compiler/typecheck/TcEvidence.hs @@ -162,7 +162,7 @@ data HsWrapper -- Hence (\a. []) `WpCompose` (\b. []) = (\a b. []) -- But ([] a) `WpCompose` ([] b) = ([] b a) - | WpFun HsWrapper HsWrapper TcType + | WpFun HsWrapper HsWrapper TcType SDoc -- (WpFun wrap1 wrap2 t1)[e] = \(x:t1). wrap2[ e wrap1[x] ] -- So note that if wrap1 :: exp_arg <= act_arg -- wrap2 :: act_res <= exp_res @@ -170,6 +170,9 @@ data HsWrapper -- This isn't the same as for mkFunCo, but it has to be this way -- because we can't use 'sym' to flip around these HsWrappers -- The TcType is the "from" type of the first wrapper + -- The SDoc explains the circumstances under which we have created this + -- WpFun, in case we run afoul of levity polymorphism restrictions in + -- the desugarer. See Note [Levity polymorphism checking] in DsMonad | WpCast TcCoercionR -- A cast: [] `cast` co -- Guaranteed not the identity coercion @@ -186,8 +189,67 @@ data HsWrapper | WpLet TcEvBinds -- Non-empty (or possibly non-empty) evidence bindings, -- so that the identity coercion is always exactly WpHole - deriving Data.Data +-- Cannot derive Data instance because SDoc is not Data (it stores a function). +-- So we do it manually: +instance Data.Data HsWrapper where + gfoldl _ z WpHole = z WpHole + gfoldl k z (WpCompose a1 a2) = z WpCompose `k` a1 `k` a2 + gfoldl k z (WpFun a1 a2 a3 _) = z wpFunEmpty `k` a1 `k` a2 `k` a3 + gfoldl k z (WpCast a1) = z WpCast `k` a1 + gfoldl k z (WpEvLam a1) = z WpEvLam `k` a1 + gfoldl k z (WpEvApp a1) = z WpEvApp `k` a1 + gfoldl k z (WpTyLam a1) = z WpTyLam `k` a1 + gfoldl k z (WpTyApp a1) = z WpTyApp `k` a1 + gfoldl k z (WpLet a1) = z WpLet `k` a1 + + gunfold k z c = case Data.constrIndex c of + 1 -> z WpHole + 2 -> k (k (z WpCompose)) + 3 -> k (k (k (z wpFunEmpty))) + 4 -> k (z WpCast) + 5 -> k (z WpEvLam) + 6 -> k (z WpEvApp) + 7 -> k (z WpTyLam) + 8 -> k (z WpTyApp) + _ -> k (z WpLet) + + toConstr WpHole = wpHole_constr + toConstr (WpCompose _ _) = wpCompose_constr + toConstr (WpFun _ _ _ _) = wpFun_constr + toConstr (WpCast _) = wpCast_constr + toConstr (WpEvLam _) = wpEvLam_constr + toConstr (WpEvApp _) = wpEvApp_constr + toConstr (WpTyLam _) = wpTyLam_constr + toConstr (WpTyApp _) = wpTyApp_constr + toConstr (WpLet _) = wpLet_constr + + dataTypeOf _ = hsWrapper_dataType + +hsWrapper_dataType :: Data.DataType +hsWrapper_dataType + = Data.mkDataType "HsWrapper" + [ wpHole_constr, wpCompose_constr, wpFun_constr, wpCast_constr + , wpEvLam_constr, wpEvApp_constr, wpTyLam_constr, wpTyApp_constr + , wpLet_constr] + +wpHole_constr, wpCompose_constr, wpFun_constr, wpCast_constr, wpEvLam_constr, + wpEvApp_constr, wpTyLam_constr, wpTyApp_constr, wpLet_constr :: Data.Constr +wpHole_constr = mkHsWrapperConstr "WpHole" +wpCompose_constr = mkHsWrapperConstr "WpCompose" +wpFun_constr = mkHsWrapperConstr "WpFun" +wpCast_constr = mkHsWrapperConstr "WpCast" +wpEvLam_constr = mkHsWrapperConstr "WpEvLam" +wpEvApp_constr = mkHsWrapperConstr "WpEvApp" +wpTyLam_constr = mkHsWrapperConstr "WpTyLam" +wpTyApp_constr = mkHsWrapperConstr "WpTyApp" +wpLet_constr = mkHsWrapperConstr "WpLet" + +mkHsWrapperConstr :: String -> Data.Constr +mkHsWrapperConstr name = Data.mkConstr hsWrapper_dataType name [] Data.Prefix + +wpFunEmpty :: HsWrapper -> HsWrapper -> TcType -> HsWrapper +wpFunEmpty c1 c2 t1 = WpFun c1 c2 t1 empty (<.>) :: HsWrapper -> HsWrapper -> HsWrapper WpHole <.> c = c @@ -198,12 +260,13 @@ mkWpFun :: HsWrapper -> HsWrapper -> TcType -- the "from" type of the first wrapper -> TcType -- either type of the second wrapper (used only when the -- second wrapper is the identity) + -> SDoc -- what caused you to want a WpFun? Something like "When converting ..." -> HsWrapper -mkWpFun WpHole WpHole _ _ = WpHole -mkWpFun WpHole (WpCast co2) t1 _ = WpCast (mkTcFunCo Representational (mkTcRepReflCo t1) co2) -mkWpFun (WpCast co1) WpHole _ t2 = WpCast (mkTcFunCo Representational (mkTcSymCo co1) (mkTcRepReflCo t2)) -mkWpFun (WpCast co1) (WpCast co2) _ _ = WpCast (mkTcFunCo Representational (mkTcSymCo co1) co2) -mkWpFun co1 co2 t1 _ = WpFun co1 co2 t1 +mkWpFun WpHole WpHole _ _ _ = WpHole +mkWpFun WpHole (WpCast co2) t1 _ _ = WpCast (mkTcFunCo Representational (mkTcRepReflCo t1) co2) +mkWpFun (WpCast co1) WpHole _ t2 _ = WpCast (mkTcFunCo Representational (mkTcSymCo co1) (mkTcRepReflCo t2)) +mkWpFun (WpCast co1) (WpCast co2) _ _ _ = WpCast (mkTcFunCo Representational (mkTcSymCo co1) co2) +mkWpFun co1 co2 t1 _ d = WpFun co1 co2 t1 d -- | @mkWpFuns [(ty1, wrap1), (ty2, wrap2)] ty_res wrap_res@, -- where @wrap1 :: ty1 "->" ty1'@ and @wrap2 :: ty2 "->" ty2'@, @@ -211,13 +274,14 @@ mkWpFun co1 co2 t1 _ = WpFun co1 co2 t1 -- gives a wrapper @(ty1' -> ty2' -> ty3) "->" (ty1 -> ty2 -> ty3')@. -- Notice that the result wrapper goes the other way round to all -- the others. This is a result of sub-typing contravariance. -mkWpFuns :: [(TcType, HsWrapper)] -> TcType -> HsWrapper -> HsWrapper -mkWpFuns args res_ty res_wrap = snd $ go args res_ty res_wrap +-- The SDoc is a description of what you were doing when you called mkWpFuns. +mkWpFuns :: [(TcType, HsWrapper)] -> TcType -> HsWrapper -> SDoc -> HsWrapper +mkWpFuns args res_ty res_wrap doc = snd $ go args res_ty res_wrap where go [] res_ty res_wrap = (res_ty, res_wrap) go ((arg_ty, arg_wrap) : args) res_ty res_wrap = let (tail_ty, tail_wrap) = go args res_ty res_wrap in - (arg_ty `mkFunTy` tail_ty, mkWpFun arg_wrap tail_wrap arg_ty tail_ty) + (arg_ty `mkFunTy` tail_ty, mkWpFun arg_wrap tail_wrap arg_ty tail_ty doc) mkWpCastR :: TcCoercionR -> HsWrapper mkWpCastR co @@ -762,7 +826,7 @@ evVarsOfTypeable ev = instance Outputable HsWrapper where ppr co_fn = pprHsWrapper co_fn (no_parens (text "<>")) -pprHsWrapper ::HsWrapper -> (Bool -> SDoc) -> SDoc +pprHsWrapper :: HsWrapper -> (Bool -> SDoc) -> SDoc -- With -fprint-typechecker-elaboration, print the wrapper -- otherwise just print what's inside -- The pp_thing_inside function takes Bool to say whether @@ -778,7 +842,7 @@ pprHsWrapper wrap pp_thing_inside -- False <=> appears as body of let or lambda help it WpHole = it help it (WpCompose f1 f2) = help (help it f2) f1 - help it (WpFun f1 f2 t1) = add_parens $ text "\\(x" <> dcolon <> ppr t1 <> text ")." <+> + help it (WpFun f1 f2 t1 _) = add_parens $ text "\\(x" <> dcolon <> ppr t1 <> text ")." <+> help (\_ -> it True <+> help (\_ -> text "x") f1 True) f2 False help it (WpCast co) = add_parens $ sep [it False, nest 2 (text "|>" <+> pprParendCo co)] diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index 71fe070006..4c21a859e8 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -388,8 +388,9 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty -- op' :: (a2_ty -> res_ty) -> a2_ty -> res_ty -- wrap1 :: arg1_ty "->" (arg2_sigma -> res_ty) - wrap1 = mkWpFun idHsWrapper wrap_res arg2_sigma res_ty + wrap1 = mkWpFun idHsWrapper wrap_res arg2_sigma res_ty doc <.> wrap_arg1 + doc = text "When looking at the argument to ($)" ; return (OpApp (mkLHsWrap wrap1 arg1') op' fix arg2') } @@ -1230,9 +1231,12 @@ tcArgs fun orig_fun_ty fun_orig orig_args herald ; (inner_wrap, args', inner_res_ty) <- go (arg_ty : acc_args) (n+1) res_ty args -- inner_wrap :: res_ty "->" (map typeOf args') -> inner_res_ty - ; return ( mkWpFun idHsWrapper inner_wrap arg_ty res_ty <.> wrap + ; return ( mkWpFun idHsWrapper inner_wrap arg_ty res_ty doc <.> wrap , Left arg' : args' , inner_res_ty ) } + where + doc = text "When checking the" <+> speakNth n <+> + text "argument to" <+> quotes (ppr fun) ty_app_err ty arg = do { (_, ty) <- zonkTidyTcType emptyTidyEnv ty @@ -1356,9 +1360,10 @@ tcSynArgE orig sigma_ty syn_ty thing_inside ; return ( result , match_wrapper <.> mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper - arg_ty res_ty ) } + arg_ty res_ty doc ) } where herald = text "This rebindable syntax expects a function with" + doc = text "When checking a rebindable syntax operator arising from" <+> ppr orig go rho_ty (SynType the_ty) = do { wrap <- tcSubTypeET orig GenSigCtxt the_ty rho_ty @@ -1631,21 +1636,21 @@ tc_infer_id lbl id_name return_data_con con -- For data constructors, must perform the stupid-theta check | null stupid_theta - = return_id con_wrapper_id + = return (HsConLikeOut (RealDataCon con), con_ty) | otherwise -- See Note [Instantiating stupid theta] - = do { let (tvs, theta, rho) = tcSplitSigmaTy (idType con_wrapper_id) + = do { let (tvs, theta, rho) = tcSplitSigmaTy con_ty ; (subst, tvs') <- newMetaTyVars tvs ; let tys' = mkTyVarTys tvs' theta' = substTheta subst theta rho' = substTy subst rho ; wrap <- instCall (OccurrenceOf id_name) tys' theta' ; addDataConStupidTheta con tys' - ; return (mkHsWrap wrap (HsVar (noLoc con_wrapper_id)), rho') } + ; return (mkHsWrap wrap (HsConLikeOut (RealDataCon con)), rho') } where - con_wrapper_id = dataConWrapId con + con_ty = dataConUserType con stupid_theta = dataConStupidTheta con check_naughty id diff --git a/compiler/typecheck/TcGenFunctor.hs b/compiler/typecheck/TcGenFunctor.hs index 5679f9ff42..21875ffa5b 100644 --- a/compiler/typecheck/TcGenFunctor.hs +++ b/compiler/typecheck/TcGenFunctor.hs @@ -130,12 +130,13 @@ gen_Functor_binds loc tycon data_cons = tyConDataCons tycon fun_name = L loc fmap_RDR fmap_bind = mkRdrFunBind fun_name eqns + fun_match_ctxt = FunRhs fun_name Prefix - fmap_eqn con = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs + fmap_eqn con = evalState (match_for_con fun_match_ctxt [f_Pat] con =<< parts) bs_RDRs where parts = sequence $ foldDataConArgs ft_fmap con - eqns | null data_cons = [mkSimpleMatch (FunRhs fun_name Prefix) + eqns | null data_cons = [mkSimpleMatch fun_match_ctxt [nlWildPat, nlWildPat] (error_Expr "Void fmap")] | otherwise = map fmap_eqn data_cons @@ -153,7 +154,7 @@ gen_Functor_binds loc tycon -- fmap f = \x b -> h (x (g b)) , ft_tup = \t gs -> do gg <- sequence gs - mkSimpleLam $ mkSimpleTupleCase match_for_con t gg + mkSimpleLam $ mkSimpleTupleCase (match_for_con CaseAlt) t gg -- fmap f = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..) , ft_ty_app = \_ g -> nlHsApp fmap_Expr <$> g -- fmap f = fmap g @@ -162,9 +163,10 @@ gen_Functor_binds loc tycon , ft_co_var = panic "contravariant" } -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ... - match_for_con :: [LPat RdrName] -> DataCon -> [LHsExpr RdrName] + match_for_con :: HsMatchContext RdrName + -> [LPat RdrName] -> DataCon -> [LHsExpr RdrName] -> State [RdrName] (LMatch RdrName (LHsExpr RdrName)) - match_for_con = mkSimpleConMatch CaseAlt $ + match_for_con ctxt = mkSimpleConMatch ctxt $ \con_name xs -> return $ nlHsApps con_name xs -- Con x1 x2 .. {- diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 9f320f5835..581795ef92 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -12,8 +12,11 @@ checker. {-# LANGUAGE CPP, TupleSections #-} module TcHsSyn ( - mkHsDictLet, mkHsApp, + -- * Extracting types from HsSyn hsLitType, hsLPatType, hsPatType, + + -- * Other HsSyn functions + mkHsDictLet, mkHsApp, mkHsAppTy, mkHsCaseAlt, nlHsIntLit, shortCutLit, hsOverLitName, @@ -32,24 +35,22 @@ module TcHsSyn ( zonkTcTypeToType, zonkTcTypeToTypes, zonkTyVarOcc, zonkCoToCo, zonkSigType, zonkEvBinds, - - -- * Validity checking - checkForRepresentationPolymorphism ) where #include "HsVersions.h" import HsSyn import Id +import IdInfo import TcRnMonad import PrelNames import TcType import TcMType import TcEvidence import TysPrim +import TyCon ( isUnboxedTupleTyCon ) import TysWiredIn import Type -import TyCon import Coercion import ConLike import DataCon @@ -57,7 +58,6 @@ import HscTypes import Name import NameEnv import Var -import VarSet import VarEnv import DynFlags import Literal @@ -76,12 +76,10 @@ import Control.Arrow ( second ) {- ************************************************************************ * * -\subsection[mkFailurePair]{Code for pattern-matching and other failures} + Extracting the type from HsSyn * * ************************************************************************ -Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@, -then something is wrong. -} hsLPatType :: OutPat Id -> Type @@ -109,7 +107,6 @@ hsPatType (NPlusKPat _ _ _ _ _ ty) = ty hsPatType (CoPat _ _ ty) = ty hsPatType p = pprPanic "hsPatType" (ppr p) - hsLitType :: HsLit -> TcType hsLitType (HsChar _ _) = charTy hsLitType (HsCharPrim _ _) = charPrimTy @@ -150,7 +147,7 @@ shortCutLit _ (HsIsString src s) ty | otherwise = Nothing mkLit :: DataCon -> HsLit -> HsExpr Id -mkLit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit) +mkLit con lit = HsApp (nlHsDataCon con) (nlHsLit lit) ------------------------------ hsOverLitName :: OverLitVal -> Name @@ -296,11 +293,12 @@ zonkIdOccs env ids = map (zonkIdOcc env) ids -- zonkIdBndr is used *after* typechecking to get the Id's type -- to its final form. The TyVarEnv give zonkIdBndr :: ZonkEnv -> TcId -> TcM Id -zonkIdBndr env id - = do ty' <- zonkTcTypeToType env (idType id) - ensureNotRepresentationPolymorphic ty' - (text "In the type of binder" <+> quotes (ppr id)) - return (setIdType id ty') +zonkIdBndr env v + = do ty' <- zonkTcTypeToType env (idType v) + ensureNotLevPoly ty' + (text "In the type of binder" <+> quotes (ppr v)) + + return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdType v ty')) zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id] zonkIdBndrs env ids = mapM (zonkIdBndr env) ids @@ -617,7 +615,10 @@ zonkLExprs env exprs = mapM (zonkLExpr env) exprs zonkLExpr env expr = wrapLocM (zonkExpr env) expr zonkExpr env (HsVar (L l id)) - = return (HsVar (L l (zonkIdOcc env id))) + = ASSERT( isNothing (isDataConId_maybe id) ) + return (HsVar (L l (zonkIdOcc env id))) + +zonkExpr _ e@(HsConLikeOut {}) = return e zonkExpr _ (HsIPVar id) = return (HsIPVar id) @@ -930,6 +931,12 @@ zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids) new_stack_tys <- zonkTcTypeToType env stack_tys new_ty <- zonkTcTypeToType env ty new_ids <- mapSndM (zonkExpr env) ids + + MASSERT( isLiftedTypeKind (typeKind new_stack_tys) ) + -- desugarer assumes that this is not levity polymorphic... + -- but indeed it should always be lifted due to the typing + -- rules for arrows + return (HsCmdTop new_cmd new_stack_tys new_ty new_ids) ------------------------------------------------------------------------- @@ -938,10 +945,10 @@ zonkCoFn env WpHole = return (env, WpHole) zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1 ; (env2, c2') <- zonkCoFn env1 c2 ; return (env2, WpCompose c1' c2') } -zonkCoFn env (WpFun c1 c2 t1) = do { (env1, c1') <- zonkCoFn env c1 - ; (env2, c2') <- zonkCoFn env1 c2 - ; t1' <- zonkTcTypeToType env2 t1 - ; return (env2, WpFun c1' c2' t1') } +zonkCoFn env (WpFun c1 c2 t1 d) = do { (env1, c1') <- zonkCoFn env c1 + ; (env2, c2') <- zonkCoFn env1 c2 + ; t1' <- zonkTcTypeToType env2 t1 + ; return (env2, WpFun c1' c2' t1' d) } zonkCoFn env (WpCast co) = do { co' <- zonkCoToCo env co ; return (env, WpCast co') } zonkCoFn env (WpEvLam ev) = do { (env', ev') <- zonkEvBndrX env ev @@ -1181,7 +1188,7 @@ zonk_pat env (ParPat p) zonk_pat env (WildPat ty) = do { ty' <- zonkTcTypeToType env ty - ; ensureNotRepresentationPolymorphic ty' + ; ensureNotLevPoly ty' (text "In a wildcard pattern") ; return (env, WildPat ty') } @@ -1237,9 +1244,19 @@ zonk_pat env (SumPat pat alt arity tys) zonk_pat env p@(ConPatOut { pat_arg_tys = tys, pat_tvs = tyvars , pat_dicts = evs, pat_binds = binds - , pat_args = args, pat_wrap = wrapper }) + , pat_args = args, pat_wrap = wrapper + , pat_con = L _ con }) = ASSERT( all isImmutableTyVar tyvars ) do { new_tys <- mapM (zonkTcTypeToType env) tys + + -- an unboxed tuple pattern (but only an unboxed tuple pattern) + -- might have levity-polymorphic arguments. Check for this badness. + ; case con of + RealDataCon dc + | isUnboxedTupleTyCon (dataConTyCon dc) + -> mapM_ (checkForLevPoly doc) (dropRuntimeRepArgs new_tys) + _ -> return () + ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars -- Must zonk the existential variables, because their -- /kind/ need potential zonking. @@ -1254,6 +1271,8 @@ zonk_pat env p@(ConPatOut { pat_arg_tys = tys, pat_tvs = tyvars pat_binds = new_binds, pat_args = new_args, pat_wrap = new_wrapper}) } + where + doc = text "In the type of an element of an unboxed tuple pattern:" $$ ppr p zonk_pat env (LitPat lit) = return (env, LitPat lit) @@ -1630,10 +1649,10 @@ zonkTvSkolemising tv zonkTypeZapping :: UnboundTyVarZonker -- This variant is used for everything except the LHS of rules -- It zaps unbound type variables to Any, except for RuntimeRep --- vars which it zonks to PtrRepLIfted +-- vars which it zonks to LiftedRep -- Works on both types and kinds zonkTypeZapping tv - = do { let ty | isRuntimeRepVar tv = ptrRepLiftedTy + = do { let ty | isRuntimeRepVar tv = liftedRepTy | otherwise = anyTypeOfKind (tyVarKind tv) ; writeMetaTyVar tv ty ; return ty } @@ -1670,118 +1689,4 @@ We do this in two stages. Quantifying here is awkward because (a) the data type is big and (b) finding the free type vars of an expression is necessarily monadic operation. (consider /\a -> f @ b, where b is side-effected to a) - -Note [Unboxed tuples in representation polymorphism check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Recall that all types that have values (that is, lifted and unlifted -types) have kinds that look like (TYPE rep), where (rep :: RuntimeRep) -tells how the values are represented at runtime. Lifted types have -kind (TYPE PtrRepLifted) (for which * is just a synonym) and, say, -Int# has kind (TYPE IntRep). - -It would be terrible if the code generator came upon a binder of a type -whose kind is something like TYPE r, where r is a skolem type variable. -The code generator wouldn't know what to do. So we eliminate that case -here. - -Although representation polymorphism and the RuntimeRep type catch -most ways of abusing unlifted types, it still isn't quite satisfactory -around unboxed tuples. That's because all unboxed tuple types have kind -TYPE UnboxedTupleRep, which is clearly a lie: it doesn't actually tell -you what the representation is. - -Naively, when checking for representation polymorphism, you might think we can -just look for free variables in a type's RuntimeRep. But this misses the -UnboxedTupleRep case. - -So, instead, we handle unboxed tuples specially. Only after unboxed tuples -are handled do we look for free tyvars in a RuntimeRep. - -We must still be careful in the UnboxedTupleRep case. A binder whose type -has kind UnboxedTupleRep is OK -- only as long as the type is really an -unboxed tuple, which the code generator treats specially. So we do this: - 1. Check if the type is an unboxed tuple. If so, recur. - 2. Check if the kind is TYPE UnboxedTupleRep. If so, error. - 3. Check if the kind has any free variables. If so, error. - -In case 1, we have a type that looks like - - (# , #) PtrRepLifted IntRep Bool Int# - -recalling that - - (# , #) :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep). - TYPE r1 -> TYPE r2 -> TYPE UnboxedTupleRep - -It's tempting just to look at the RuntimeRep arguments to make sure -that they are devoid of free variables and not UnboxedTupleRep. This -naive check, though, fails on nested unboxed tuples, like -(# Int#, (# Bool, Void# #) #). Thus, instead of looking at the RuntimeRep -args to the unboxed tuple constructor, we look at the types themselves. - -Here are a few examples: - - type family F r :: TYPE r - - x :: (F r :: TYPE r) -- REJECTED: simple representation polymorphism - where r is an in-scope type variable of kind RuntimeRep - - x :: (F PtrRepLifted :: TYPE PtrRepLifted) -- OK - x :: (F IntRep :: TYPE IntRep) -- OK - - x :: (F UnboxedTupleRep :: TYPE UnboxedTupleRep) -- REJECTED - - x :: ((# Int, Bool #) :: TYPE UnboxedTupleRep) -- OK -} - --- | According to the rules around representation polymorphism --- (see https://ghc.haskell.org/trac/ghc/wiki/NoSubKinds), no binder --- can have a representation-polymorphic type. This check ensures --- that we respect this rule. It is a bit regrettable that this error --- occurs in zonking, after which we should have reported all errors. --- But it's hard to see where else to do it, because this can be discovered --- only after all solving is done. And, perhaps most importantly, this --- isn't really a compositional property of a type system, so it's --- not a terrible surprise that the check has to go in an awkward spot. -ensureNotRepresentationPolymorphic - :: Type -- its zonked type - -> SDoc -- where this happened - -> TcM () -ensureNotRepresentationPolymorphic ty doc - = whenNoErrs $ -- sometimes we end up zonking bogus definitions of type - -- forall a. a. See, for example, test ghci/scripts/T9140 - checkForRepresentationPolymorphism doc ty - - -- See Note [Unboxed tuples in representation polymorphism check] -checkForRepresentationPolymorphism :: SDoc -> Type -> TcM () -checkForRepresentationPolymorphism extra ty - | Just (tc, tys) <- splitTyConApp_maybe ty - , isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc - = mapM_ (checkForRepresentationPolymorphism extra) (dropRuntimeRepArgs tys) - - | tuple_rep || sum_rep - = addErr (vcat [ text "The type" <+> quotes (ppr tidy_ty) <+> - (text "is not an unboxed" <+> tuple_or_sum <> comma) - , text "and yet its kind suggests that it has the representation" - , text "of an unboxed" <+> tuple_or_sum <> text ". This is not allowed." ] $$ - extra) - - | not (isEmptyVarSet (tyCoVarsOfType runtime_rep)) - = addErr $ - hang (text "A representation-polymorphic type is not allowed here:") - 2 (vcat [ text "Type:" <+> ppr tidy_ty - , text "Kind:" <+> ppr tidy_ki ]) $$ - extra - - | otherwise - = return () - where - tuple_rep = runtime_rep `eqType` unboxedTupleRepDataConTy - sum_rep = runtime_rep `eqType` unboxedSumRepDataConTy - tuple_or_sum = text (if tuple_rep then "tuple" else "sum") - - ki = typeKind ty - runtime_rep = getRuntimeRepFromKind "check_type" ki - - (tidy_env, tidy_ty) = tidyOpenType emptyTidyEnv ty - tidy_ki = tidyType tidy_env (typeKind ty) diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 107f4f9162..15f6217f90 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -65,7 +65,6 @@ import VarSet import TyCon import ConLike import DataCon -import TysPrim ( tYPE ) import Class import Name import NameEnv @@ -605,8 +604,11 @@ tc_hs_type mode (HsSumTy hs_tys) exp_kind = do { let arity = length hs_tys ; arg_kinds <- mapM (\_ -> newOpenTypeKind) hs_tys ; tau_tys <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds - ; let arg_tys = map (getRuntimeRepFromKind "tc_hs_type HsSumTy") arg_kinds ++ tau_tys - ; checkExpectedKind (mkTyConApp (sumTyCon arity) arg_tys) (tYPE unboxedSumRepDataConTy) exp_kind + ; let arg_reps = map (getRuntimeRepFromKind "tc_hs_type HsSumTy") arg_kinds + arg_tys = arg_reps ++ tau_tys + ; checkExpectedKind (mkTyConApp (sumTyCon arity) arg_tys) + (unboxedSumKind arg_reps) + exp_kind } --------- Promoted lists and tuples @@ -717,8 +719,7 @@ finish_tuple tup_sort tau_tys tau_kinds exp_kind = do { traceTc "finish_tuple" (ppr res_kind $$ ppr tau_kinds $$ ppr exp_kind) ; let arg_tys = case tup_sort of -- See also Note [Unboxed tuple RuntimeRep vars] in TyCon - UnboxedTuple -> map (getRuntimeRepFromKind "finish_tuple") tau_kinds - ++ tau_tys + UnboxedTuple -> tau_reps ++ tau_tys BoxedTuple -> tau_tys ConstraintTuple -> tau_tys ; tycon <- case tup_sort of @@ -733,10 +734,9 @@ finish_tuple tup_sort tau_tys tau_kinds exp_kind ; checkExpectedKind (mkTyConApp tycon arg_tys) res_kind exp_kind } where arity = length tau_tys + tau_reps = map (getRuntimeRepFromKind "finish_tuple") tau_kinds res_kind = case tup_sort of - UnboxedTuple - | arity == 0 -> tYPE voidRepDataConTy - | otherwise -> unboxedTupleKind + UnboxedTuple -> unboxedTupleKind tau_reps BoxedTuple -> liftedTypeKind ConstraintTuple -> constraintKind diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index 4b2b383b83..9298b109e0 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -42,6 +42,7 @@ import TcEvidence import TyCon import CoAxiom import DataCon +import ConLike import Class import Var import VarEnv @@ -835,7 +836,8 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) -- con_app_tys = MkD ty1 ty2 -- con_app_scs = MkD ty1 ty2 sc1 sc2 -- con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2 - con_app_tys = wrapId (mkWpTyApps inst_tys) (dataConWrapId dict_constr) + con_app_tys = mkHsWrap (mkWpTyApps inst_tys) + (HsConLikeOut (RealDataCon dict_constr)) -- NB: We *can* have covars in inst_tys, in the case of -- promoted GADT constructors. @@ -892,6 +894,8 @@ addDFunPrags dfun_id sc_meth_ids where con_app = mkLams dfun_bndrs $ mkApps (Var (dataConWrapId dict_con)) dict_args + -- mkApps is OK because of the checkForLevPoly call in checkValidClass + -- See Note [Levity polymorphism checking] in DsMonad dict_args = map Type inst_tys ++ [mkVarApps (Var id) dfun_bndrs | id <- sc_meth_ids] diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs index 2e9a7a7d05..8f0a79c352 100644 --- a/compiler/typecheck/TcMType.hs +++ b/compiler/typecheck/TcMType.hs @@ -81,7 +81,11 @@ module TcMType ( zonkEvVar, zonkWC, zonkSimples, zonkId, zonkCt, zonkSkolemInfo, - tcGetGlobalTyCoVars + tcGetGlobalTyCoVars, + + ------------------------------ + -- Levity polymorphism + ensureNotLevPoly, checkForLevPoly, checkForLevPolyX, formatLevPolyErr ) where #include "HsVersions.h" @@ -1011,7 +1015,7 @@ zonkQuantifiedTyVar default_kind tv zonk_meta_tv :: TcTyVar -> TcM (Maybe TcTyVar) zonk_meta_tv tv | isRuntimeRepVar tv -- Never quantify over a RuntimeRep var - = do { writeMetaTyVar tv ptrRepLiftedTy + = do { writeMetaTyVar tv liftedRepTy ; return Nothing } | default_kind -- -XNoPolyKinds and this is a kind var @@ -1569,3 +1573,55 @@ tidySkolemInfo env (SigSkol cx ty) = SigSkol cx (tidyType env ty) tidySkolemInfo env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids) tidySkolemInfo env (UnifyForAllSkol ty) = UnifyForAllSkol (tidyType env ty) tidySkolemInfo _ info = info + +------------------------------------------------------------------------- +{- +%************************************************************************ +%* * + Levity polymorphism checks +* * +************************************************************************ + +See Note [Levity polymorphism checking] in DsMonad + +-} + +-- | According to the rules around representation polymorphism +-- (see https://ghc.haskell.org/trac/ghc/wiki/NoSubKinds), no binder +-- can have a representation-polymorphic type. This check ensures +-- that we respect this rule. It is a bit regrettable that this error +-- occurs in zonking, after which we should have reported all errors. +-- But it's hard to see where else to do it, because this can be discovered +-- only after all solving is done. And, perhaps most importantly, this +-- isn't really a compositional property of a type system, so it's +-- not a terrible surprise that the check has to go in an awkward spot. +ensureNotLevPoly :: Type -- its zonked type + -> SDoc -- where this happened + -> TcM () +ensureNotLevPoly ty doc + = whenNoErrs $ -- sometimes we end up zonking bogus definitions of type + -- forall a. a. See, for example, test ghci/scripts/T9140 + checkForLevPoly doc ty + + -- See Note [Levity polymorphism checking] in DsMonad +checkForLevPoly :: SDoc -> Type -> TcM () +checkForLevPoly = checkForLevPolyX addErr + +checkForLevPolyX :: Monad m + => (SDoc -> m ()) -- how to report an error + -> SDoc -> Type -> m () +checkForLevPolyX add_err extra ty + | isTypeLevPoly ty + = add_err (formatLevPolyErr ty $$ extra) + | otherwise + = return () + +formatLevPolyErr :: Type -- levity-polymorphic type + -> SDoc +formatLevPolyErr ty + = hang (text "A levity-polymorphic type is not allowed here:") + 2 (vcat [ text "Type:" <+> ppr tidy_ty + , text "Kind:" <+> ppr tidy_ki ]) + where + (tidy_env, tidy_ty) = tidyOpenType emptyTidyEnv ty + tidy_ki = tidyType tidy_env (typeKind ty) diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index b1d444aee5..036482d723 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -47,7 +47,6 @@ import VarSet import Util import Outputable import qualified GHC.LanguageExtensions as LangExt -import Control.Monad import Control.Arrow ( second ) import ListSetOps ( getNth ) @@ -336,7 +335,7 @@ tc_pat penv (BangPat pat) pat_ty thing_inside = do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside ; return (BangPat pat', res) } -tc_pat penv lpat@(LazyPat pat) pat_ty thing_inside +tc_pat penv (LazyPat pat) pat_ty thing_inside = do { (pat', (res, pat_ct)) <- tc_lpat pat pat_ty (makeLazy penv) $ captureConstraints thing_inside @@ -346,18 +345,6 @@ tc_pat penv lpat@(LazyPat pat) pat_ty thing_inside -- captureConstraints/extendConstraints: -- see Note [Hopping the LIE in lazy patterns] - -- Check there are no unlifted types under the lazy pattern - -- This is a very unsatisfactory test. We have to zonk because - -- the binder-tys are typically just a unification variable, - -- which should by now have been unified... but it might be - -- deferred for the constraint solver...Ugh! Also - -- collecting the pattern binders again is not very cool. - -- But it's all very much a corner case: a lazy pattern with - -- unboxed types inside it - ; bndr_tys <- mapM (zonkTcType . idType) (collectPatBinders pat') - ; when (any isUnliftedType bndr_tys) - (lazyUnliftedPatErr lpat) - -- Check that the expected pattern type is itself lifted ; pat_ty <- readExpType pat_ty ; _ <- unifyType noThing (typeKind pat_ty) liftedTypeKind @@ -406,10 +393,11 @@ tc_pat penv (ViewPat expr pat _) overall_pat_ty thing_inside ; overall_pat_ty <- readExpType overall_pat_ty ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper - overall_pat_ty inf_res_ty + overall_pat_ty inf_res_ty doc -- expr_wrap2' :: (inf_arg_ty -> inf_res_ty) "->" -- (overall_pat_ty -> inf_res_ty) expr_wrap = expr_wrap2' <.> expr_wrap1 + doc = text "When checking the view pattern function:" <+> (ppr expr) ; return (ViewPat (mkLHsWrap expr_wrap expr') pat' overall_pat_ty, res) } -- Type signatures in patterns @@ -1185,9 +1173,3 @@ polyPatSig :: TcType -> SDoc polyPatSig sig_ty = hang (text "Illegal polymorphic type signature in pattern:") 2 (ppr sig_ty) - -lazyUnliftedPatErr :: (OutputableBndrId name) => Pat name -> TcM () -lazyUnliftedPatErr pat - = failWithTc $ - hang (text "A lazy (~) pattern cannot contain unlifted types:") - 2 (ppr pat) diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index 47a27b3853..587e2b8806 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -34,7 +34,7 @@ import FastString import Var import VarEnv( emptyTidyEnv, mkInScopeSet ) import Id -import IdInfo( RecSelParent(..)) +import IdInfo( RecSelParent(..), setLevityInfoWithType ) import TcBinds import BasicTypes import TcSimplify @@ -330,7 +330,6 @@ tc_patsyn_finish lname dir is_infix lpat' (args, arg_tys) pat_ty - -- Make the 'builder' ; builder_id <- mkPatSynBuilderId dir lname univ_tvs req_theta @@ -343,6 +342,7 @@ tc_patsyn_finish lname dir is_infix lpat' , flSelector = name } field_labels' = map mkFieldLabel field_labels + -- Make the PatSyn itself ; let patSyn = mkPatSyn (unLoc lname) is_infix (univ_tvs, req_theta) @@ -429,7 +429,7 @@ tcPatSynMatcher (L loc name) lpat HsLam $ MG{ mg_alts = noLoc [mkSimpleMatch LambdaExpr args body] - , mg_arg_tys = [pat_ty, cont_ty, res_ty] + , mg_arg_tys = [pat_ty, cont_ty, fail_ty] , mg_res_ty = res_ty , mg_origin = Generated } @@ -500,7 +500,9 @@ mkPatSynBuilderId dir (L _ name) builder_id = mkExportedVanillaId builder_name builder_sigma -- See Note [Exported LocalIds] in Id - ; return (Just (builder_id, need_dummy_arg)) } + builder_id' = modifyIdInfo (`setLevityInfoWithType` pat_ty) builder_id + + ; return (Just (builder_id', need_dummy_arg)) } where tcPatSynBuilderBind :: PatSynBind Name Name @@ -571,11 +573,12 @@ tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr TcId, TcSigmaType) -- monadic only for failure tcPatSynBuilderOcc ps | Just (builder_id, add_void_arg) <- builder - , let builder_expr = HsVar (noLoc builder_id) + , let builder_expr = HsConLikeOut (PatSynCon ps) builder_ty = idType builder_id = return $ if add_void_arg - then ( HsApp (noLoc $ builder_expr) (nlHsVar voidPrimId) + then ( builder_expr -- still just return builder_expr; the void# arg is added + -- by dsConLike in the desugarer , tcFunResultTy builder_ty ) else (builder_expr, builder_ty) diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 40638e7578..46a1ea9872 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -3083,6 +3083,7 @@ ctoHerald = text "arising from" exprCtOrigin :: HsExpr Name -> CtOrigin exprCtOrigin (HsVar (L _ name)) = OccurrenceOf name exprCtOrigin (HsUnboundVar uv) = UnboundOccurrenceOf (unboundVarOcc uv) +exprCtOrigin (HsConLikeOut {}) = panic "exprCtOrigin HsConLikeOut" exprCtOrigin (HsRecFld f) = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f) exprCtOrigin (HsOverLabel l) = OverLabelOrigin l exprCtOrigin (HsIPVar ip) = IPOccOrigin ip diff --git a/compiler/typecheck/TcSigs.hs b/compiler/typecheck/TcSigs.hs index 3e63493758..bd72d8aaf1 100644 --- a/compiler/typecheck/TcSigs.hs +++ b/compiler/typecheck/TcSigs.hs @@ -30,7 +30,6 @@ import TcRnTypes import TcRnMonad import TcType import TcMType -import TcHsSyn ( checkForRepresentationPolymorphism ) import TcValidity ( checkValidType ) import TcUnify( tcSkolemise, unifyType, noThing ) import Inst( topInstantiate ) @@ -390,7 +389,7 @@ tcPatSynSig name sig_ty -- arguments become the types of binders. We thus cannot allow -- levity polymorphism here ; let (arg_tys, _) = tcSplitFunTys body_ty - ; mapM_ (checkForRepresentationPolymorphism empty) arg_tys + ; mapM_ (checkForLevPoly empty) arg_tys ; traceTc "tcTySig }" $ vcat [ text "implicit_tvs" <+> ppr_tvs implicit_tvs diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs index c8af1f32fa..ccc37d5952 100644 --- a/compiler/typecheck/TcSimplify.hs +++ b/compiler/typecheck/TcSimplify.hs @@ -38,7 +38,7 @@ import TcSMonad as TcS import TcType import TrieMap () -- DV: for now import Type -import TysWiredIn ( ptrRepLiftedTy ) +import TysWiredIn ( liftedRepTy ) import Unify ( tcMatchTyKi ) import Util import Var @@ -1608,15 +1608,14 @@ promoteTyVarTcS tclvl tv | otherwise = return () --- | If the tyvar is a RuntimeRep var, set it to PtrRepLifted. Returns whether or --- not this happened. +-- | If the tyvar is a RuntimeRep var, set it to LiftedRep. defaultTyVar :: TcTyVar -> TcM () -- Precondition: MetaTyVars only -- See Note [DefaultTyVar] defaultTyVar the_tv | isRuntimeRepVar the_tv = do { traceTc "defaultTyVar RuntimeRep" (ppr the_tv) - ; writeMetaTyVar the_tv ptrRepLiftedTy } + ; writeMetaTyVar the_tv liftedRepTy } | otherwise = return () -- The common case @@ -1625,7 +1624,7 @@ defaultTyVarTcS :: TcTyVar -> TcS Bool defaultTyVarTcS the_tv | isRuntimeRepVar the_tv = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv) - ; unifyTyVar the_tv ptrRepLiftedTy + ; unifyTyVar the_tv liftedRepTy ; return True } | otherwise = return False -- the common case @@ -1715,7 +1714,7 @@ There are two caveats: Note [DefaultTyVar] ~~~~~~~~~~~~~~~~~~~ defaultTyVar is used on any un-instantiated meta type variables to -default any RuntimeRep variables to PtrRepLifted. This is important +default any RuntimeRep variables to LiftedRep. This is important to ensure that instance declarations match. For example consider instance Show (a->b) @@ -1731,7 +1730,7 @@ hand. However we aren't ready to default them fully to () or whatever, because the type-class defaulting rules have yet to run. An alternate implementation would be to emit a derived constraint setting -the RuntimeRep variable to PtrRepLifted, but this seems unnecessarily indirect. +the RuntimeRep variable to LiftedRep, but this seems unnecessarily indirect. Note [Promote _and_ default when inferring] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 34ce53f04b..e790a11405 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -2303,7 +2303,7 @@ checkValidDataCon dflags existential_ok tc con -- Check all argument types for validity ; checkValidType ctxt (dataConUserType con) - ; mapM_ (checkForRepresentationPolymorphism empty) + ; mapM_ (checkForLevPoly empty) (dataConOrigArgTys con) -- Extra checks for newtype data constructors @@ -2440,6 +2440,13 @@ checkValidClass cls -- newBoard :: MonadState b m => m () -- Here, MonadState has a fundep m->b, so newBoard is fine + -- a method cannot be levity polymorphic, as we have to store the + -- method in a dictionary + -- example of what this prevents: + -- class BoundedX (a :: TYPE r) where minBound :: a + -- See Note [Levity polymorphism checking] in DsMonad + ; checkForLevPoly empty tau1 + ; unless constrained_class_methods $ mapM_ check_constraint (tail (theta1 ++ theta2)) diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs index 68a329e25b..48a2f06a44 100644 --- a/compiler/typecheck/TcType.hs +++ b/compiler/typecheck/TcType.hs @@ -15,7 +15,7 @@ The "tc" prefix is for "TypeChecker", because the type checker is the principal client. -} -{-# LANGUAGE CPP, MultiWayIf #-} +{-# LANGUAGE CPP, MultiWayIf, FlexibleContexts #-} module TcType ( -------------------------------- @@ -60,7 +60,8 @@ module TcType ( tcSplitForAllTy_maybe, tcSplitForAllTys, tcSplitPiTys, tcSplitForAllTyVarBndrs, tcSplitPhiTy, tcSplitPredFunTy_maybe, - tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcSplitFunTysN, + tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcFunResultTyN, + tcSplitFunTysN, tcSplitTyConApp, tcSplitTyConApp_maybe, tcRepSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs, tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcRepSplitAppTy_maybe, @@ -142,7 +143,7 @@ module TcType ( mkClassPred, isDictLikeTy, tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy, - isRuntimeRepVar, isLevityPolymorphic, + isRuntimeRepVar, isKindLevPoly, isVisibleBinder, isInvisibleBinder, -- Type substitutions @@ -172,6 +173,7 @@ module TcType ( tyCoFVsOfType, tyCoFVsOfTypes, tyCoVarsOfTypeDSet, tyCoVarsOfTypesDSet, closeOverKindsDSet, tyCoVarsOfTypeList, tyCoVarsOfTypesList, + noFreeVarsOfType, -------------------------------- -- Transforming Types to TcTypes @@ -198,7 +200,7 @@ import ForeignCall import VarSet import Coercion import Type -import RepType (tyConPrimRep) +import RepType import TyCon -- others: @@ -1398,7 +1400,7 @@ tcSplitFunTy_maybe _ = Nothing tcSplitFunTysN :: Arity -- N: Number of desired args -> TcRhoType -> Either Arity -- Number of missing arrows - ([TcSigmaType], -- Arg types (N or fewer) + ([TcSigmaType], -- Arg types (always N types) TcSigmaType) -- The rest of the type -- ^ Split off exactly the specified number argument types -- Returns @@ -1423,6 +1425,14 @@ tcFunArgTy ty = fst (tcSplitFunTy ty) tcFunResultTy :: Type -> Type tcFunResultTy ty = snd (tcSplitFunTy ty) +-- | Strips off n *visible* arguments and returns the resulting type +tcFunResultTyN :: HasDebugCallStack => Arity -> Type -> Type +tcFunResultTyN n ty + | Right (_, res_ty) <- tcSplitFunTysN n ty + = res_ty + | otherwise + = pprPanic "tcFunResultTyN" (ppr n <+> ppr ty) + ----------------------- tcSplitAppTy_maybe :: Type -> Maybe (Type, Type) tcSplitAppTy_maybe ty | Just ty' <- coreView ty = tcSplitAppTy_maybe ty' @@ -2279,7 +2289,7 @@ marshalableTyCon :: DynFlags -> TyCon -> Validity marshalableTyCon dflags tc | isUnliftedTyCon tc , not (isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc) - , tyConPrimRep tc /= VoidRep -- Note [Marshalling VoidRep] + , not (null (tyConPrimRep tc)) -- Note [Marshalling void] = validIfUnliftedFFITypes dflags | otherwise = boxedMarshalableTyCon tc @@ -2317,7 +2327,7 @@ legalFIPrimResultTyCon :: DynFlags -> TyCon -> Validity legalFIPrimResultTyCon dflags tc | isUnliftedTyCon tc , isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc - || tyConPrimRep tc /= VoidRep -- Note [Marshalling VoidRep] + || not (null (tyConPrimRep tc)) -- Note [Marshalling void] = validIfUnliftedFFITypes dflags | otherwise @@ -2332,8 +2342,8 @@ validIfUnliftedFFITypes dflags | otherwise = NotValid (text "To marshal unlifted types, use UnliftedFFITypes") {- -Note [Marshalling VoidRep] -~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Marshalling void] +~~~~~~~~~~~~~~~~~~~~~~~ We don't treat State# (whose PrimRep is VoidRep) as marshalable. In turn that means you can't write foreign import foo :: Int -> State# RealWorld diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs index dd8ed86281..9996a7df40 100644 --- a/compiler/typecheck/TcTypeable.hs +++ b/compiler/typecheck/TcTypeable.hs @@ -139,9 +139,9 @@ mkModIdRHS :: Module -> TcM (LHsExpr Id) mkModIdRHS mod = do { trModuleDataCon <- tcLookupDataCon trModuleDataConName ; trNameLit <- mkTrNameLit - ; return $ nlHsApps (dataConWrapId trModuleDataCon) - [ trNameLit (unitIdFS (moduleUnitId mod)) - , trNameLit (moduleNameFS (moduleName mod)) ] + ; return $ nlHsDataCon trModuleDataCon + `nlHsApp` trNameLit (unitIdFS (moduleUnitId mod)) + `nlHsApp` trNameLit (moduleNameFS (moduleName mod)) } {- ********************************************************************* @@ -245,8 +245,8 @@ mkTrNameLit :: TcM (FastString -> LHsExpr Id) mkTrNameLit = do trNameSDataCon <- tcLookupDataCon trNameSDataConName let trNameLit :: FastString -> LHsExpr Id - trNameLit fs = nlHsApps (dataConWrapId trNameSDataCon) - [nlHsLit (mkHsStringPrimLit fs)] + trNameLit fs = nlHsDataCon trNameSDataCon + `nlHsApp` nlHsLit (mkHsStringPrimLit fs) return trNameLit -- | Make bindings for the type representations of a 'TyCon' and its @@ -272,10 +272,11 @@ mkTyConRepBinds stuff@(Stuff {..}) tycon mkTyConRepRHS :: TypeableStuff -> TyCon -> LHsExpr Id mkTyConRepRHS (Stuff {..}) tycon = rep_rhs where - rep_rhs = nlHsApps (dataConWrapId trTyConDataCon) - [ nlHsLit (word64 high), nlHsLit (word64 low) - , mod_rep - , trNameLit (mkFastString tycon_str) ] + rep_rhs = nlHsDataCon trTyConDataCon + `nlHsApp` nlHsLit (word64 high) + `nlHsApp` nlHsLit (word64 low) + `nlHsApp` mod_rep + `nlHsApp` trNameLit (mkFastString tycon_str) tycon_str = add_tick (occNameString (getOccName tycon)) add_tick s | isPromotedDataCon tycon = '\'' : s diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs index d8f0279862..b7c4aeeae4 100644 --- a/compiler/typecheck/TcUnify.hs +++ b/compiler/typecheck/TcUnify.hs @@ -145,7 +145,10 @@ matchExpectedFunTys herald arity orig_ty thing_inside do { (result, wrap_res) <- go (mkCheckExpType arg_ty : acc_arg_tys) (n-1) res_ty ; return ( result - , mkWpFun idHsWrapper wrap_res arg_ty res_ty ) } + , mkWpFun idHsWrapper wrap_res arg_ty res_ty doc ) } + where + doc = text "When inferring the argument type of a function with type" <+> + quotes (ppr orig_ty) go acc_arg_tys n ty@(TyVarTy tv) | isMetaTyVar tv @@ -271,8 +274,11 @@ matchActualFunTysPart herald ct_orig mb_thing arity orig_ty go n acc_args (FunTy arg_ty res_ty) = ASSERT( not (isPredTy arg_ty) ) do { (wrap_res, tys, ty_r) <- go (n-1) (arg_ty : acc_args) res_ty - ; return ( mkWpFun idHsWrapper wrap_res arg_ty ty_r + ; return ( mkWpFun idHsWrapper wrap_res arg_ty ty_r doc , arg_ty : tys, ty_r ) } + where + doc = text "When inferring the argument type of a function with type" <+> + quotes (ppr orig_ty) go n acc_args ty@(TyVarTy tv) | isMetaTyVar tv @@ -392,7 +398,7 @@ matchExpectedTyConApp tc orig_ty -- This happened in Trac #7368 defer = do { (_, arg_tvs) <- newMetaTyVars (tyConTyVars tc) - ; traceTc "mtca" (ppr tc $$ ppr (tyConTyVars tc) $$ ppr arg_tvs) + ; traceTc "matchExpectedTyConApp" (ppr tc $$ ppr (tyConTyVars tc) $$ ppr arg_tvs) ; let args = mkTyVarTys arg_tvs tc_template = mkTyConApp tc args ; co <- unifyType noThing tc_template orig_ty @@ -718,9 +724,12 @@ tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty_expected <- tc_sub_tc_type eq_orig (GivenOrigin (SigSkol GenSigCtxt exp_arg)) ctxt exp_arg act_arg - ; return (mkWpFun arg_wrap res_wrap exp_arg exp_res) } + ; return (mkWpFun arg_wrap res_wrap exp_arg exp_res doc) } -- arg_wrap :: exp_arg ~> act_arg -- res_wrap :: act-res ~> exp_res + where + doc = text "When checking that" <+> quotes (ppr ty_actual) <+> + text "is more polymorphic than" <+> quotes (ppr ty_expected) go ty_a ty_e | let (tvs, theta, _) = tcSplitSigmaTy ty_a @@ -1222,7 +1231,7 @@ uType_defer origin t_or_k ty1 ty2 -------------- uType origin t_or_k orig_ty1 orig_ty2 = do { tclvl <- getTcLevel - ; traceTc "u_tys " $ vcat + ; traceTc "u_tys" $ vcat [ text "tclvl" <+> ppr tclvl , sep [ ppr orig_ty1, text "~", ppr orig_ty2] , pprCtOrigin origin] diff --git a/compiler/types/FamInstEnv.hs b/compiler/types/FamInstEnv.hs index f90cf4eb4b..7abac119f1 100644 --- a/compiler/types/FamInstEnv.hs +++ b/compiler/types/FamInstEnv.hs @@ -1234,8 +1234,6 @@ topNormaliseType_maybe :: FamInstEnvs -> Type -> Maybe (Coercion, Type) -- -- However, ty' can be something like (Maybe (F ty)), where -- (F ty) is a redex. --- --- Its a bit like Type.repType, but handles type families too topNormaliseType_maybe env ty = topNormaliseTypeX stepper mkTransCo ty diff --git a/compiler/types/Kind.hs b/compiler/types/Kind.hs index 4db98fc25c..b67eec0874 100644 --- a/compiler/types/Kind.hs +++ b/compiler/types/Kind.hs @@ -14,7 +14,7 @@ module Kind ( classifiesTypeWithValues, isStarKind, isStarKindSynonymTyCon, - isLevityPolymorphic + isKindLevPoly ) where #include "HsVersions.h" @@ -23,9 +23,11 @@ import {-# SOURCE #-} Type ( typeKind, coreViewOneStarKind ) import TyCoRep import TyCon -import VarSet ( isEmptyVarSet ) import PrelNames +import Outputable +import Util + {- ************************************************************************ * * @@ -77,11 +79,29 @@ returnsTyCon _ _ = False returnsConstraintKind :: Kind -> Bool returnsConstraintKind = returnsTyCon constraintKindTyConKey --- | Tests whether the given kind (which should look like "TYPE ...") --- has any free variables -isLevityPolymorphic :: Kind -> Bool -isLevityPolymorphic k - = not $ isEmptyVarSet $ tyCoVarsOfType k +-- | Tests whether the given kind (which should look like @TYPE x@) +-- is something other than a constructor tree (that is, constructors at every node). +isKindLevPoly :: Kind -> Bool +isKindLevPoly k = ASSERT2( isStarKind k || _is_type, ppr k ) + -- the isStarKind check is necessary b/c of Constraint + go k + where + go ty | Just ty' <- coreViewOneStarKind ty = go ty' + go TyVarTy{} = True + go AppTy{} = True -- it can't be a TyConApp + go (TyConApp tc tys) = isFamilyTyCon tc || any go tys + go ForAllTy{} = True + go (FunTy t1 t2) = go t1 || go t2 + go LitTy{} = False + go CastTy{} = True + go CoercionTy{} = True + + _is_type + | TyConApp typ [_] <- k + = typ `hasKey` tYPETyConKey + | otherwise + = False + -------------------------------------------- -- Kinding for arrow (->) @@ -114,7 +134,7 @@ isStarKind :: Kind -> Bool isStarKind k | Just k' <- coreViewOneStarKind k = isStarKind k' isStarKind (TyConApp tc [TyConApp ptr_rep []]) = tc `hasKey` tYPETyConKey - && ptr_rep `hasKey` ptrRepLiftedDataConKey + && ptr_rep `hasKey` liftedRepDataConKey isStarKind _ = False -- See Note [Kind Constraint and kind *] @@ -137,8 +157,8 @@ Trac #12708): data T rep (a :: TYPE rep) = MkT (a -> Int) - x1 :: T LiftedPtrRep Int - x1 = MkT LiftedPtrRep Int (\x::Int -> 3) + x1 :: T LiftedRep Int + x1 = MkT LiftedRep Int (\x::Int -> 3) x2 :: T IntRep Int# x2 = MkT IntRep Int# (\x:Int# -> 3) diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs index ef6917aeba..a8e074caf4 100644 --- a/compiler/types/TyCoRep.hs +++ b/compiler/types/TyCoRep.hs @@ -79,6 +79,8 @@ module TyCoRep ( tyCoVarsOfCoList, tyCoVarsOfProv, closeOverKinds, + noFreeVarsOfType, noFreeVarsOfCo, + -- * Substitutions TCvSubst(..), TvSubstEnv, CvSubstEnv, emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubstEnv, composeTCvSubst, @@ -683,24 +685,34 @@ mkTyConTy tycon = TyConApp tycon [] Some basic functions, put here to break loops eg with the pretty printer -} --- | This version considers Constraint to be distinct from *. +is_TYPE :: ( Type -- the single argument to TYPE; not a synonym + -> Bool ) -- what to return + -> Kind -> Bool +is_TYPE f ki | Just ki' <- coreView ki = is_TYPE f ki' +is_TYPE f (TyConApp tc [arg]) + | tc `hasKey` tYPETyConKey + = go arg + where + go ty | Just ty' <- coreView ty = go ty' + go ty = f ty +is_TYPE _ _ = False + +-- | This version considers Constraint to be distinct from *. Returns True +-- if the argument is equivalent to Type and False otherwise. isLiftedTypeKind :: Kind -> Bool -isLiftedTypeKind ki | Just ki' <- coreView ki = isLiftedTypeKind ki' -isLiftedTypeKind (TyConApp tc [TyConApp ptr_rep []]) - = tc `hasKey` tYPETyConKey - && ptr_rep `hasKey` ptrRepLiftedDataConKey -isLiftedTypeKind _ = False +isLiftedTypeKind = is_TYPE is_lifted + where + is_lifted (TyConApp lifted_rep []) = lifted_rep `hasKey` liftedRepDataConKey + is_lifted _ = False +-- | Returns True if the kind classifies unlifted types and False otherwise. +-- Note that this returns False for levity-polymorphic kinds, which may +-- be specialized to a kind that classifies unlifted types. isUnliftedTypeKind :: Kind -> Bool -isUnliftedTypeKind ki | Just ki' <- coreView ki = isUnliftedTypeKind ki' -isUnliftedTypeKind (TyConApp tc [TyConApp ptr_rep []]) - | tc `hasKey` tYPETyConKey - , ptr_rep `hasKey` ptrRepLiftedDataConKey - = False -isUnliftedTypeKind (TyConApp tc [arg]) - = tc `hasKey` tYPETyConKey && isEmptyVarSet (tyCoVarsOfType arg) - -- all other possibilities are unlifted -isUnliftedTypeKind _ = False +isUnliftedTypeKind = is_TYPE is_unlifted + where + is_unlifted (TyConApp rr _args) = not (rr `hasKey` liftedRepDataConKey) + is_unlifted _ = False -- | Is this the type 'RuntimeRep'? isRuntimeRepTy :: Type -> Bool @@ -708,7 +720,7 @@ isRuntimeRepTy ty | Just ty' <- coreView ty = isRuntimeRepTy ty' isRuntimeRepTy (TyConApp tc []) = tc `hasKey` runtimeRepTyConKey isRuntimeRepTy _ = False --- | Is this a type of kind RuntimeRep? (e.g. PtrRep) +-- | Is this a type of kind RuntimeRep? (e.g. LiftedRep) isRuntimeRepKindedTy :: Type -> Bool isRuntimeRepKindedTy = isRuntimeRepTy . typeKind @@ -717,9 +729,9 @@ isRuntimeRepVar :: TyVar -> Bool isRuntimeRepVar = isRuntimeRepTy . tyVarKind -- | Drops prefix of RuntimeRep constructors in 'TyConApp's. Useful for e.g. --- dropping 'PtrRep arguments of unboxed tuple TyCon applications: +-- dropping 'LiftedRep arguments of unboxed tuple TyCon applications: -- --- dropRuntimeRepArgs [ 'PtrRepLifted, 'PtrRepUnlifted +-- dropRuntimeRepArgs [ 'LiftedRep, 'IntRep -- , String, Int# ] == [String, Int#] -- dropRuntimeRepArgs :: [Type] -> [Type] @@ -1536,6 +1548,49 @@ closeOverKindsList tvs = fvVarList $ closeOverKindsFV tvs closeOverKindsDSet :: DTyVarSet -> DTyVarSet closeOverKindsDSet = fvDVarSet . closeOverKindsFV . dVarSetElems +-- | Returns True if this type has no free variables. Should be the same as +-- isEmptyVarSet . tyCoVarsOfType, but faster in the non-forall case. +noFreeVarsOfType :: Type -> Bool +noFreeVarsOfType (TyVarTy _) = False +noFreeVarsOfType (AppTy t1 t2) = noFreeVarsOfType t1 && noFreeVarsOfType t2 +noFreeVarsOfType (TyConApp _ tys) = all noFreeVarsOfType tys +noFreeVarsOfType ty@(ForAllTy {}) = isEmptyVarSet (tyCoVarsOfType ty) +noFreeVarsOfType (FunTy t1 t2) = noFreeVarsOfType t1 && noFreeVarsOfType t2 +noFreeVarsOfType (LitTy _) = True +noFreeVarsOfType (CastTy ty co) = noFreeVarsOfType ty && noFreeVarsOfCo co +noFreeVarsOfType (CoercionTy co) = noFreeVarsOfCo co + +-- | Returns True if this coercion has no free variables. Should be the same as +-- isEmptyVarSet . tyCoVarsOfCo, but faster in the non-forall case. +noFreeVarsOfCo :: Coercion -> Bool +noFreeVarsOfCo (Refl _ ty) = noFreeVarsOfType ty +noFreeVarsOfCo (TyConAppCo _ _ args) = all noFreeVarsOfCo args +noFreeVarsOfCo (AppCo c1 c2) = noFreeVarsOfCo c1 && noFreeVarsOfCo c2 +noFreeVarsOfCo co@(ForAllCo {}) = isEmptyVarSet (tyCoVarsOfCo co) +noFreeVarsOfCo (CoVarCo _) = False +noFreeVarsOfCo (AxiomInstCo _ _ args) = all noFreeVarsOfCo args +noFreeVarsOfCo (UnivCo p _ t1 t2) = noFreeVarsOfProv p && + noFreeVarsOfType t1 && + noFreeVarsOfType t2 +noFreeVarsOfCo (SymCo co) = noFreeVarsOfCo co +noFreeVarsOfCo (TransCo co1 co2) = noFreeVarsOfCo co1 && noFreeVarsOfCo co2 +noFreeVarsOfCo (NthCo _ co) = noFreeVarsOfCo co +noFreeVarsOfCo (LRCo _ co) = noFreeVarsOfCo co +noFreeVarsOfCo (InstCo co1 co2) = noFreeVarsOfCo co1 && noFreeVarsOfCo co2 +noFreeVarsOfCo (CoherenceCo co1 co2) = noFreeVarsOfCo co1 && noFreeVarsOfCo co2 +noFreeVarsOfCo (KindCo co) = noFreeVarsOfCo co +noFreeVarsOfCo (SubCo co) = noFreeVarsOfCo co +noFreeVarsOfCo (AxiomRuleCo _ cs) = all noFreeVarsOfCo cs + +-- | Returns True if this UnivCoProv has no free variables. Should be the same as +-- isEmptyVarSet . tyCoVarsOfProv, but faster in the non-forall case. +noFreeVarsOfProv :: UnivCoProvenance -> Bool +noFreeVarsOfProv UnsafeCoerceProv = True +noFreeVarsOfProv (PhantomProv co) = noFreeVarsOfCo co +noFreeVarsOfProv (ProofIrrelProv co) = noFreeVarsOfCo co +noFreeVarsOfProv (PluginProv {}) = True +noFreeVarsOfProv (HoleProv {}) = True -- matches with coVarsOfProv, but I'm unsure + {- %************************************************************************ %* * @@ -2233,7 +2288,7 @@ substForAllCoBndrCallback sym sco (TCvSubst in_scope tenv cenv) TyVarTy new_var `CastTy` new_kind_co | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) - no_kind_change = isEmptyVarSet (tyCoVarsOfCo old_kind_co) + no_kind_change = noFreeVarsOfCo old_kind_co no_change = no_kind_change && (new_var == old_var) new_kind_co | no_kind_change = old_kind_co @@ -2282,7 +2337,7 @@ substTyVarBndrCallback subst_fn subst@(TCvSubst in_scope tenv cenv) old_var -- Assertion check that we are not capturing something in the substitution old_ki = tyVarKind old_var - no_kind_change = isEmptyVarSet (tyCoVarsOfType old_ki) -- verify that kind is closed + no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed no_change = no_kind_change && (new_var == old_var) -- no_change means that the new_var is identical in -- all respects to the old_var (same unique, same kind) @@ -2313,7 +2368,7 @@ substCoVarBndrCallback sym subst_fun subst@(TCvSubst in_scope tenv cenv) old_var -- In that case, mkCoVarCo will return a ReflCoercion, and -- we want to substitute that (not new_var) for old_var new_co = (if sym then mkSymCo else id) $ mkCoVarCo new_var - no_kind_change = isEmptyVarSet (tyCoVarsOfTypes [t1, t2]) + no_kind_change = all noFreeVarsOfType [t1, t2] no_change = new_var == old_var && not (isReflCo new_co) && no_kind_change new_cenv | no_change = delVarEnv cenv old_var @@ -2336,7 +2391,7 @@ cloneTyVarBndr subst@(TCvSubst in_scope tv_env cv_env) tv uniq (extendVarEnv tv_env tv (mkTyVarTy tv')) cv_env, tv') where old_ki = tyVarKind tv - no_kind_change = isEmptyVarSet (tyCoVarsOfType old_ki) -- verify that kind is closed + no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed tv1 | no_kind_change = tv | otherwise = setTyVarKind tv (substTy subst old_ki) diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs index fdb6aaaf1a..45efb486a6 100644 --- a/compiler/types/TyCon.hs +++ b/compiler/types/TyCon.hs @@ -67,7 +67,7 @@ module TyCon( isTyConAssoc, tyConAssoc_maybe, isImplicitTyCon, isTyConWithSrcDataCons, - isTcTyCon, + isTcTyCon, isTcLevPoly, -- ** Extracting information out of TyCons tyConName, @@ -870,7 +870,7 @@ instance Binary HowAbstract where -- up things like @RuntimeRep@'s @PrimRep@ by known-key every time. data RuntimeRepInfo = NoRRI -- ^ an ordinary promoted data con - | RuntimeRep ([Type] -> PrimRep) + | RuntimeRep ([Type] -> [PrimRep]) -- ^ A constructor of @RuntimeRep@. The argument to the function should -- be the list of arguments to the promoted datacon. | VecCount Int -- ^ A constructor of @VecCount@ @@ -1269,12 +1269,13 @@ CmmType GcPtrCat W32 on a 64-bit machine. -- and store values of this type. data PrimRep = VoidRep - | PtrRep + | LiftedRep + | UnliftedRep -- ^ Unlifted pointer | IntRep -- ^ Signed, word-sized value | WordRep -- ^ Unsigned, word-sized value | Int64Rep -- ^ Signed, 64 bit value (with 32-bit words only) | Word64Rep -- ^ Unsigned, 64 bit value (with 32-bit words only) - | AddrRep -- ^ A pointer, but /not/ to a Haskell value (use 'PtrRep') + | AddrRep -- ^ A pointer, but /not/ to a Haskell value (use '(Un)liftedRep') | FloatRep | DoubleRep | VecRep Int PrimElemRep -- ^ A vector @@ -1304,8 +1305,9 @@ isVoidRep VoidRep = True isVoidRep _other = False isGcPtrRep :: PrimRep -> Bool -isGcPtrRep PtrRep = True -isGcPtrRep _ = False +isGcPtrRep LiftedRep = True +isGcPtrRep UnliftedRep = True +isGcPtrRep _ = False -- | Find the size of a 'PrimRep', in words primRepSizeW :: DynFlags -> PrimRep -> Int @@ -1316,7 +1318,8 @@ primRepSizeW dflags Word64Rep = wORD64_SIZE `quot` wORD_SIZE dflags primRepSizeW _ FloatRep = 1 -- NB. might not take a full word primRepSizeW dflags DoubleRep = dOUBLE_SIZE dflags `quot` wORD_SIZE dflags primRepSizeW _ AddrRep = 1 -primRepSizeW _ PtrRep = 1 +primRepSizeW _ LiftedRep = 1 +primRepSizeW _ UnliftedRep = 1 primRepSizeW _ VoidRep = 0 primRepSizeW dflags (VecRep len rep) = len * primElemRepSizeB rep `quot` wORD_SIZE dflags @@ -1518,9 +1521,9 @@ mkTcTyCon name binders res_kind unsat scoped_tvs , tyConArity = length binders , tcTyConScopedTyVars = scoped_tvs } --- | Create an unlifted primitive 'TyCon', such as @Int#@ +-- | Create an unlifted primitive 'TyCon', such as @Int#@. mkPrimTyCon :: Name -> [TyConBinder] - -> Kind -- ^ /result/ kind + -> Kind -- ^ /result/ kind, never levity-polymorphic -> [Role] -> TyCon mkPrimTyCon name binders res_kind roles = mkPrimTyCon' name binders res_kind roles True (Just $ mkPrelTyConRepName name) @@ -1543,7 +1546,9 @@ mkLiftedPrimTyCon name binders res_kind roles where rep_nm = mkPrelTyConRepName name mkPrimTyCon' :: Name -> [TyConBinder] - -> Kind -- ^ /result/ kind + -> Kind -- ^ /result/ kind, never levity-polymorphic + -- (If you need a levity-polymorphic PrimTyCon, change + -- isTcLevPoly.) -> [Role] -> Bool -> Maybe TyConRepName -> TyCon mkPrimTyCon' name binders res_kind roles is_unlifted rep_nm @@ -2043,6 +2048,20 @@ isTcTyCon :: TyCon -> Bool isTcTyCon (TcTyCon {}) = True isTcTyCon _ = False +-- | Could this TyCon ever be levity-polymorphic when fully applied? +-- True is safe. False means we're sure. Does only a quick check +-- based on the TyCon's category. +-- Precondition: The fully-applied TyCon has kind (TYPE blah) +isTcLevPoly :: TyCon -> Bool +isTcLevPoly FunTyCon{} = False +isTcLevPoly (AlgTyCon { algTcParent = UnboxedAlgTyCon }) = True +isTcLevPoly AlgTyCon{} = False +isTcLevPoly SynonymTyCon{} = True +isTcLevPoly FamilyTyCon{} = True +isTcLevPoly PrimTyCon{} = False +isTcLevPoly tc@PromotedDataCon{} = pprPanic "isTcLevPoly datacon" (ppr tc) +isTcLevPoly tc@TcTyCon{} = pprPanic "isTcLevPoly TcTyCon" (ppr tc) + {- ----------------------------------------------- -- Expand type-constructor applications diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs index 14aa8fd38d..818fab7181 100644 --- a/compiler/types/Type.hs +++ b/compiler/types/Type.hs @@ -3,7 +3,7 @@ -- -- Type - public interface -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Main functions for manipulating types and type-related things @@ -102,7 +102,7 @@ module Type ( isPiTy, isTauTy, isFamFreeTy, -- (Lifting and boxity) - isUnliftedType, isUnboxedTupleType, isUnboxedSumType, + isLiftedType_maybe, isUnliftedType, isUnboxedTupleType, isUnboxedSumType, isAlgType, isClosedAlgType, isPrimitiveType, isStrictType, isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy, @@ -113,7 +113,7 @@ module Type ( Kind, -- ** Finding the kind of a type - typeKind, + typeKind, isTypeLevPoly, resultIsLevPoly, -- ** Common Kind liftedTypeKind, @@ -124,6 +124,7 @@ module Type ( tyCoVarsOfTypeDSet, coVarsOfType, coVarsOfTypes, closeOverKinds, closeOverKindsList, + noFreeVarsOfType, splitVisVarsOfType, splitVisVarsOfTypes, expandTypeSynonyms, typeSize, @@ -317,7 +318,7 @@ coreView (TyConApp tc tys) | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc t coreView _ = Nothing -- | Like 'coreView', but it also "expands" @Constraint@ to become --- @TYPE PtrRepLifted@. +-- @TYPE LiftedRep@. {-# INLINE coreViewOneStarKind #-} coreViewOneStarKind :: Type -> Maybe Type coreViewOneStarKind ty @@ -1842,49 +1843,63 @@ isFamFreeTy (CoercionTy _) = False -- Not sure about this ************************************************************************ -} --- | See "Type#type_classification" for what an unlifted type is -isUnliftedType :: Type -> Bool +-- | Returns Just True if this type is surely lifted, Just False +-- if it is surely unlifted, Nothing if we can't be sure (i.e., it is +-- levity polymorphic), and panics if the kind does not have the shape +-- TYPE r. +isLiftedType_maybe :: HasDebugCallStack => Type -> Maybe Bool +isLiftedType_maybe ty = go (getRuntimeRep "isLiftedType_maybe" ty) + where + go rr | Just rr' <- coreView rr = go rr' + go (TyConApp lifted_rep []) + | lifted_rep `hasKey` liftedRepDataConKey = Just True + go (TyConApp {}) = Just False -- everything else is unlifted + go _ = Nothing -- levity polymorphic + +-- | See "Type#type_classification" for what an unlifted type is. +-- Panics on levity polymorphic types. +isUnliftedType :: HasDebugCallStack => Type -> Bool -- isUnliftedType returns True for forall'd unlifted types: -- x :: forall a. Int# -- I found bindings like these were getting floated to the top level. -- They are pretty bogus types, mind you. It would be better never to -- construct them - -isUnliftedType ty | Just ty' <- coreView ty = isUnliftedType ty' -isUnliftedType (ForAllTy _ ty) = isUnliftedType ty -isUnliftedType (TyConApp tc _) = isUnliftedTyCon tc -isUnliftedType _ = False +isUnliftedType ty + = not (isLiftedType_maybe ty `orElse` + pprPanic "isUnliftedType" (ppr ty <+> dcolon <+> ppr (typeKind ty))) -- | Extract the RuntimeRep classifier of a type. Panics if this is not possible. -getRuntimeRep :: String -- ^ Printed in case of an error +getRuntimeRep :: HasDebugCallStack + => String -- ^ Printed in case of an error -> Type -> Type getRuntimeRep err ty = getRuntimeRepFromKind err (typeKind ty) -- | Extract the RuntimeRep classifier of a type from its kind. --- For example, getRuntimeRepFromKind * = PtrRepLifted; --- getRuntimeRepFromKind # = PtrRepUnlifted. +-- For example, getRuntimeRepFromKind * = LiftedRep; -- Panics if this is not possible. -getRuntimeRepFromKind :: String -- ^ Printed in case of an error +getRuntimeRepFromKind :: HasDebugCallStack + => String -- ^ Printed in case of an error -> Type -> Type getRuntimeRepFromKind err = go where go k | Just k' <- coreViewOneStarKind k = go k' go k - | Just (tc, [arg]) <- splitTyConApp_maybe k - , tc `hasKey` tYPETyConKey - = arg + | (_tc, [arg]) <- splitTyConApp k + = ASSERT2( _tc `hasKey` tYPETyConKey, text err $$ ppr k ) + arg go k = pprPanic "getRuntimeRep" (text err $$ ppr k <+> dcolon <+> ppr (typeKind k)) isUnboxedTupleType :: Type -> Bool -isUnboxedTupleType ty = case tyConAppTyCon_maybe ty of - Just tc -> isUnboxedTupleTyCon tc - _ -> False +isUnboxedTupleType ty + = tyConAppTyCon (getRuntimeRep "isUnboxedTupleType" ty) `hasKey` tupleRepDataConKey + -- NB: Do not use typePrimRep, as that can't tell the difference between + -- unboxed tuples and unboxed sums + isUnboxedSumType :: Type -> Bool -isUnboxedSumType ty = case tyConAppTyCon_maybe ty of - Just tc -> isUnboxedSumTyCon tc - _ -> False +isUnboxedSumType ty + = tyConAppTyCon (getRuntimeRep "isUnboxedSumType" ty) `hasKey` sumRepDataConKey -- | See "Type#type_classification" for what an algebraic type is. -- Should only be applied to /types/, as opposed to e.g. partially @@ -1909,9 +1924,8 @@ isClosedAlgType ty -- | Computes whether an argument (or let right hand side) should -- be computed strictly or lazily, based only on its type. --- Currently, it's just 'isUnliftedType'. - -isStrictType :: Type -> Bool +-- Currently, it's just 'isUnliftedType'. Panics on levity-polymorphic types. +isStrictType :: HasDebugCallStack => Type -> Bool isStrictType = isUnliftedType isPrimitiveType :: Type -> Bool @@ -2160,6 +2174,30 @@ typeLiteralKind l = NumTyLit _ -> typeNatKind StrTyLit _ -> typeSymbolKind +-- | Returns True if a type is levity polymorphic. Should be the same +-- as (isKindLevPoly . typeKind) but much faster. +-- Precondition: The type has kind (TYPE blah) +isTypeLevPoly :: Type -> Bool +isTypeLevPoly = go + where + go ty@(TyVarTy {}) = check_kind ty + go ty@(AppTy {}) = check_kind ty + go ty@(TyConApp tc _) | not (isTcLevPoly tc) = False + | otherwise = check_kind ty + go (ForAllTy _ ty) = go ty + go (FunTy {}) = False + go (LitTy {}) = False + go ty@(CastTy {}) = check_kind ty + go ty@(CoercionTy {}) = pprPanic "isTypeLevPoly co" (ppr ty) + + check_kind = isKindLevPoly . typeKind + +-- | Looking past all pi-types, is the end result potentially levity polymorphic? +-- Example: True for (forall r (a :: TYPE r). String -> a) +-- Example: False for (forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). a -> b -> Type) +resultIsLevPoly :: Type -> Bool +resultIsLevPoly = isTypeLevPoly . snd . splitPiTys + {- %************************************************************************ %* * diff --git a/compiler/utils/Bag.hs b/compiler/utils/Bag.hs index 5fd4ba3b83..57711629c9 100644 --- a/compiler/utils/Bag.hs +++ b/compiler/utils/Bag.hs @@ -16,7 +16,7 @@ module Bag ( elemBag, lengthBag, filterBag, partitionBag, partitionBagWith, concatBag, catBagMaybes, foldBag, foldrBag, foldlBag, - isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, + isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, allBag, listToBag, bagToList, mapAccumBagL, concatMapBag, mapMaybeBag, foldrBagM, foldlBagM, mapBagM, mapBagM_, @@ -110,6 +110,12 @@ filterBagM pred (ListBag vs) = do sat <- filterM pred vs return (listToBag sat) +allBag :: (a -> Bool) -> Bag a -> Bool +allBag _ EmptyBag = True +allBag p (UnitBag v) = p v +allBag p (TwoBags b1 b2) = allBag p b1 && allBag p b2 +allBag p (ListBag xs) = all p xs + anyBag :: (a -> Bool) -> Bag a -> Bool anyBag _ EmptyBag = False anyBag p (UnitBag v) = p v diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs index 93afffefe2..118ef321f7 100644 --- a/compiler/utils/Outputable.hs +++ b/compiler/utils/Outputable.hs @@ -205,6 +205,12 @@ data QualifyName -- Given P:M.T | NameNotInScope2 -- It's not in scope at all, and M.T is already bound in -- the current scope, so we must refer to it as "P:M.T" +instance Outputable QualifyName where + ppr NameUnqual = text "NameUnqual" + ppr (NameQual _mod) = text "NameQual" -- can't print the mod without module loops :( + ppr NameNotInScope1 = text "NameNotInScope1" + ppr NameNotInScope2 = text "NameNotInScope2" + reallyAlwaysQualifyNames :: QueryQualifyName reallyAlwaysQualifyNames _ _ = NameNotInScope2 diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst index 103d6ac93d..52163b976f 100644 --- a/docs/users_guide/glasgow_exts.rst +++ b/docs/users_guide/glasgow_exts.rst @@ -175,8 +175,9 @@ There are some restrictions on the use of primitive types: binding. - You may bind unboxed variables in a (non-recursive, non-top-level) - pattern binding, but you must make any such pattern-match strict. For - example, rather than: + pattern binding, but you must make any such pattern-match strict. + (Failing to do so emits a warning :ghc-flag:`-Wunbanged-strict-patterns`.) + For example, rather than: :: @@ -227,10 +228,6 @@ unnecessary allocation during sequences of operations. There are some restrictions on the use of unboxed tuples: -- Values of unboxed tuple types are subject to the same restrictions as - other unboxed types; i.e. they may not be stored in polymorphic data - structures or passed to polymorphic functions. - - The typical use of unboxed tuples is simply to return multiple values, binding those multiple results with a ``case`` expression, thus: @@ -8015,47 +8012,42 @@ these flags, especially :ghc-flag:`-fprint-explicit-kinds`. .. index:: single: TYPE - single: representation polymorphism + single: levity polymorphism .. _runtime-rep: -Runtime representation polymorphism -=================================== +Levity polymorphism +=================== In order to allow full flexibility in how kinds are used, it is necessary to use the kind system to differentiate between boxed, lifted types (normal, everyday types like ``Int`` and ``[Bool]``) and unboxed, primitive -types (:ref:`primitives`) like ``Int#``. We thus have so-called representation +types (:ref:`primitives`) like ``Int#``. We thus have so-called levity polymorphism. -.. note:: - For quite some time, this idea was known as *levity* polymorphism, when - it differentiated between only lifted and unlifted types. Now that it - differentiates between any runtime representations, the name has been - changed. But anything you've read or heard about levity polymorphism - likely applies to the story told here -- this is just a small generalisation. - Here are the key definitions, all available from ``GHC.Exts``: :: TYPE :: RuntimeRep -> * -- highly magical, built into GHC - data RuntimeRep = PtrRepLifted -- for things like `Int` - | PtrRepUnlifted -- for things like `Array#` - | IntRep -- for things like `Int#` + data RuntimeRep = LiftedRep -- for things like `Int` + | UnliftedRep -- for things like `Array#` + | IntRep -- for `Int#` + | TupleRep [RuntimeRep] -- unboxed tuples, indexed by the representations of the elements + | SumRep [RuntimeRep] -- unboxed sums, indexed by the representations of the disjuncts | ... - type * = TYPE PtrRepLifted -- * is just an ordinary type synonym + type * = TYPE LiftedRep -- * is just an ordinary type synonym The idea is that we have a new fundamental type constant ``TYPE``, which is parameterised by a ``RuntimeRep``. We thus get ``Int# :: TYPE 'IntRep`` -and ``Bool :: TYPE 'PtrRepLifted``. Anything with a type of the form +and ``Bool :: TYPE 'LiftedRep``. Anything with a type of the form ``TYPE x`` can appear to either side of a function arrow ``->``. We can thus say that ``->`` has type -``TYPE r1 -> TYPE r2 -> TYPE 'PtrRepLifted``. The result is always lifted +``TYPE r1 -> TYPE r2 -> TYPE 'LiftedRep``. The result is always lifted because all functions are lifted in GHC. -No representation-polymorphic variables ---------------------------------------- +No levity-polymorphic variables or arguments +-------------------------------------------- If GHC didn't have to compile programs that run in the real world, that would be the end of the story. But representation polymorphism can cause @@ -8072,10 +8064,10 @@ In particular, when we call ``bad``, we must somehow pass ``x`` into ``bad``. How wide (that is, how many bits) is ``x``? Is it a pointer? What kind of register (floating-point or integral) should ``x`` go in? It's all impossible to say, because ``x``'s type, ``TYPE r2`` is -representation polymorphic. We thus forbid such constructions, via the +levity polymorphic. We thus forbid such constructions, via the following straightforward rule: - No variable may have a representation-polymorphic type. + No variable may have a levity-polymorphic type. This eliminates ``bad`` because the variable ``x`` would have a representation-polymorphic type. @@ -8086,15 +8078,20 @@ However, not all is lost. We can still do this: :: (a -> b) -> a -> b f $ x = f x -Here, only ``b`` is representation polymorphic. There are no variables -with a representation polymorphic type. And the code generator has no +Here, only ``b`` is levity polymorphic. There are no variables +with a levity-polymorphic type. And the code generator has no trouble with this. Indeed, this is the true type of GHC's ``$`` operator, slightly more general than the Haskell 98 version. -Representation-polymorphic bottoms ----------------------------------- +Because the code generator must store and move arguments as well +as variables, the logic above applies equally well to function arguments, +which may not be levity-polymorphic. + -We can use representation polymorphism to good effect with ``error`` +Levity-polymorphic bottoms +-------------------------- + +We can use levity polymorphism to good effect with ``error`` and ``undefined``, whose types are given here: :: undefined :: forall (r :: RuntimeRep) (a :: TYPE r). @@ -8102,25 +8099,25 @@ and ``undefined``, whose types are given here: :: error :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => String -> a -These functions do not bind a representation-polymorphic variable, and +These functions do not bind a levity-polymorphic variable, and so are accepted. Their polymorphism allows users to use these to conveniently stub out functions that return unboxed types. -Printing representation-polymorphic types ------------------------------------------ +Printing levity-polymorphic types +--------------------------------- .. ghc-flag:: -Wprint-explicit-runtime-rep Print ``RuntimeRep`` parameters as they appear; otherwise, they are - defaulted to ``'PtrRepLifted``. + defaulted to ``'LiftedRep``. -Most GHC users will not need to worry about representation polymorphism -or unboxed types. For these users, see the representation polymorphism +Most GHC users will not need to worry about levity polymorphism +or unboxed types. For these users, seeing the levity polymorphism in the type of ``$`` is unhelpful. And thus, by default, it is suppressed, -by supposing all type variables of type ``RuntimeType`` to be ``'PtrRepLifted`` -when printing, and printing ``TYPE 'PtrRepLifted`` as ``*``. +by supposing all type variables of type ``RuntimeRep`` to be ``'LiftedRep`` +when printing, and printing ``TYPE 'LiftedRep`` as ``*``. -Should you wish to see representation polymorphism in your types, enable +Should you wish to see levity polymorphism in your types, enable the flag :ghc-flag:`-fprint-explicit-runtime-reps`. .. _type-level-literals: diff --git a/docs/users_guide/using-warnings.rst b/docs/users_guide/using-warnings.rst index fdda600773..21f00c454e 100644 --- a/docs/users_guide/using-warnings.rst +++ b/docs/users_guide/using-warnings.rst @@ -49,6 +49,7 @@ The following flags are simple ways to select standard "packages" of warnings: * :ghc-flag:`-Wincomplete-patterns` * :ghc-flag:`-Wdodgy-exports` * :ghc-flag:`-Wdodgy-imports` + * :ghc-flag:`-Wunbanged-strict-patterns` .. ghc-flag:: -Wall @@ -1030,6 +1031,12 @@ of ``-W(no-)*``. which causes the pre-processor to warn on uses of the `#if` directive on undefined identifiers. +.. ghc-flag:: -Wunbanged-strict-patterns + + This flag warns whenever you write a pattern that binds a variable whose + type is unlifted, and yet the pattern is not a bang pattern nor a bare variable. + See :ref:`glasgow-unboxed` for informatino about unlifted types. + If you're feeling really paranoid, the :ghc-flag:`-dcore-lint` option is a good choice. It turns on heavyweight intra-pass sanity-checking within GHC. (It checks GHC's sanity, not yours.) diff --git a/docs/users_guide/using.rst b/docs/users_guide/using.rst index 7b01fc27b6..60007b0155 100644 --- a/docs/users_guide/using.rst +++ b/docs/users_guide/using.rst @@ -694,7 +694,7 @@ messages and in GHCi: .. ghc-flag:: -fprint-explicit-runtime-reps When :ghc-flag:`-fprint-explicit-runtime-reps` is enabled, GHC prints - ``RuntimeRep`` type variables for runtime-representation-polymorphic types. + ``RuntimeRep`` type variables for levity-polymorphic types. Otherwise GHC will default these to ``PtrRepLifted``. For example, .. code-block:: none diff --git a/libraries/base/Data/Typeable/Internal.hs b/libraries/base/Data/Typeable/Internal.hs index 80b1717045..0054b7a64a 100644 --- a/libraries/base/Data/Typeable/Internal.hs +++ b/libraries/base/Data/Typeable/Internal.hs @@ -355,14 +355,11 @@ instance Show TypeRep where where tcList = tyConOf @[] Proxy [TypeRep _ ptrRepCon _ []] - | tycon == tcTYPE && ptrRepCon == tc'PtrRepLifted + | tycon == tcTYPE && ptrRepCon == tc'LiftedRep -> showChar '*' - | tycon == tcTYPE && ptrRepCon == tc'PtrRepUnlifted - -> showChar '#' where - tcTYPE = tyConOf @TYPE Proxy - tc'PtrRepLifted = tyConOf @'PtrRepLifted Proxy - tc'PtrRepUnlifted = tyConOf @'PtrRepUnlifted Proxy + tcTYPE = tyConOf @TYPE Proxy + tc'LiftedRep = tyConOf @'LiftedRep Proxy [a,r] | tycon == tcFun -> showParen (p > 8) $ showsPrec 9 a . showString " -> " . diff --git a/libraries/base/Unsafe/Coerce.hs b/libraries/base/Unsafe/Coerce.hs index 684de5a209..df1c109e0e 100644 --- a/libraries/base/Unsafe/Coerce.hs +++ b/libraries/base/Unsafe/Coerce.hs @@ -44,9 +44,8 @@ If we just say then the simple-optimiser that the desugarer runs will eta-reduce to unsafeCoerce :: forall (a:*) (b:*). a -> b unsafeCoerce = unsafeCoerce# -And that, sadly, is ill-typed because unsafeCoerce# has OpenKind type variables -And rightly so, because we shouldn't be calling unsafeCoerce# in a higher -order way; it has a compulsory unfolding +But we shouldn't be calling unsafeCoerce# in a higher +order way; it has a compulsory unfolding unsafeCoerce# a b x = x |> UnsafeCo a b and we really rely on it being inlined pronto. But the simple-optimiser doesn't. The identity function local_id delays the eta reduction just long enough @@ -58,5 +57,4 @@ Sigh. This is horrible, but then so is unsafeCoerce. unsafeCoerce :: a -> b unsafeCoerce x = local_id (unsafeCoerce# x) -- See Note [Unsafe coerce magic] in basicTypes/MkId - -- NB: Do not eta-reduce this definition, else the type checker - -- give usafeCoerce the same (dangerous) type as unsafeCoerce# + -- NB: Do not eta-reduce this definition (see above) diff --git a/libraries/base/tests/T11334a.hs b/libraries/base/tests/T11334a.hs index 2b4ac56c70..0cf91eaa2a 100644 --- a/libraries/base/tests/T11334a.hs +++ b/libraries/base/tests/T11334a.hs @@ -7,5 +7,5 @@ import GHC.Types main :: IO () main = do print (typeOf (Proxy :: Proxy 'Just)) - print (typeOf (Proxy :: Proxy (TYPE 'PtrRepLifted))) - print (typeOf (Proxy :: Proxy (TYPE 'PtrRepUnlifted))) + print (typeOf (Proxy :: Proxy (TYPE 'LiftedRep))) + print (typeOf (Proxy :: Proxy (TYPE 'UnliftedRep))) diff --git a/libraries/base/tests/T11334a.stdout b/libraries/base/tests/T11334a.stdout index a00f27518d..caeb85bf44 100644 --- a/libraries/base/tests/T11334a.stdout +++ b/libraries/base/tests/T11334a.stdout @@ -1,3 +1,3 @@ Proxy (* -> Maybe *) 'Just Proxy * * -Proxy * # +Proxy * (TYPE 'UnliftedRep) diff --git a/libraries/ghc-prim/GHC/Types.hs b/libraries/ghc-prim/GHC/Types.hs index 06fc79310d..16a4921316 100644 --- a/libraries/ghc-prim/GHC/Types.hs +++ b/libraries/ghc-prim/GHC/Types.hs @@ -60,13 +60,13 @@ infixr 5 : data Constraint -- | The kind of types with values. For example @Int :: Type@. -type Type = TYPE 'PtrRepLifted +type Type = TYPE 'LiftedRep -- | A backward-compatible (pre-GHC 8.0) synonym for 'Type' -type * = TYPE 'PtrRepLifted +type * = TYPE 'LiftedRep -- | A unicode backward-compatible (pre-GHC 8.0) synonym for 'Type' -type ★ = TYPE 'PtrRepLifted +type ★ = TYPE 'LiftedRep {- ********************************************************************* * * @@ -357,7 +357,7 @@ data SPEC = SPEC | SPEC2 {- ********************************************************************* * * - RuntimeRep + Levity polymorphism * * ********************************************************************* -} @@ -374,9 +374,10 @@ data SPEC = SPEC | SPEC2 -- a further distinction is made, between lifted types (that contain ⊥), -- and unlifted ones (that don't). data RuntimeRep = VecRep VecCount VecElem -- ^ a SIMD vector type - | PtrRepLifted -- ^ lifted; represented by a pointer - | PtrRepUnlifted -- ^ unlifted; represented by a pointer - | VoidRep -- ^ erased entirely + | TupleRep [RuntimeRep] -- ^ An unboxed tuple of the given reps + | SumRep [RuntimeRep] -- ^ An unboxed sum of the given reps + | LiftedRep -- ^ lifted; represented by a pointer + | UnliftedRep -- ^ unlifted; represented by a pointer | IntRep -- ^ signed, word-sized value | WordRep -- ^ unsigned, word-sized value | Int64Rep -- ^ signed, 64-bit value (on 32-bit only) @@ -384,8 +385,6 @@ data RuntimeRep = VecRep VecCount VecElem -- ^ a SIMD vector type | AddrRep -- ^ A pointer, but /not/ to a Haskell value | FloatRep -- ^ a 32-bit floating point number | DoubleRep -- ^ a 64-bit floating point number - | UnboxedTupleRep -- ^ An unboxed tuple; this doesn't specify a concrete rep - | UnboxedSumRep -- ^ An unboxed sum; this doesn't specify a concrete rep -- See also Note [Wiring in RuntimeRep] in TysWiredIn diff --git a/libraries/integer-gmp/src/GHC/Integer/Logarithms.hs b/libraries/integer-gmp/src/GHC/Integer/Logarithms.hs index cbcc860002..76467e18a7 100644 --- a/libraries/integer-gmp/src/GHC/Integer/Logarithms.hs +++ b/libraries/integer-gmp/src/GHC/Integer/Logarithms.hs @@ -3,6 +3,7 @@ {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UnliftedFFITypes #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} module GHC.Integer.Logarithms ( wordLog2# @@ -43,7 +44,7 @@ integerLogBase# :: Integer -> Integer -> Int# integerLogBase# (S# 2#) m = integerLog2# m integerLogBase# b m = e' where - (# _, e' #) = go b + !(# _, e' #) = go b go pw | m `ltInteger` pw = (# m, 0# #) go pw = case go (sqrInteger pw) of diff --git a/libraries/integer-gmp/src/GHC/Integer/Type.hs b/libraries/integer-gmp/src/GHC/Integer/Type.hs index 9800f55692..035cb1e7ba 100644 --- a/libraries/integer-gmp/src/GHC/Integer/Type.hs +++ b/libraries/integer-gmp/src/GHC/Integer/Type.hs @@ -762,7 +762,7 @@ divModInteger n d in (# q', r' #) | True = qr where - qr@(# q, r #) = quotRemInteger n d + !qr@(# q, r #) = quotRemInteger n d {-# CONSTANT_FOLDED divModInteger #-} divInteger :: Integer -> Integer -> Integer @@ -1036,7 +1036,7 @@ timesBigNatWord !_ 0## = zeroBigNat timesBigNatWord x 1## = x timesBigNatWord x@(BN# x#) y# | isTrue# (nx# ==# 1#) = - let (# !h#, !l# #) = timesWord2# (bigNatToWord x) y# + let !(# !h#, !l# #) = timesWord2# (bigNatToWord x) y# in wordToBigNat2 h# l# | True = runS $ do mbn@(MBN# mba#) <- newBigNat# nx# @@ -1066,7 +1066,7 @@ bitBigNat i# _ <- svoid (writeBigNat# mbn li# (uncheckedShiftL# 1## bi#)) unsafeFreezeBigNat# mbn where - (# li#, bi# #) = quotRemInt# i# GMP_LIMB_BITS# + !(# li#, bi# #) = quotRemInt# i# GMP_LIMB_BITS# testBitBigNat :: BigNat -> Int# -> Bool testBitBigNat bn i# @@ -1074,7 +1074,7 @@ testBitBigNat bn i# | isTrue# (li# <# nx#) = isTrue# (testBitWord# (indexBigNat# bn li#) bi#) | True = False where - (# li#, bi# #) = quotRemInt# i# GMP_LIMB_BITS# + !(# li#, bi# #) = quotRemInt# i# GMP_LIMB_BITS# nx# = sizeofBigNat# bn testBitNegBigNat :: BigNat -> Int# -> Bool @@ -1085,7 +1085,7 @@ testBitNegBigNat bn i# (indexBigNat# bn li# `minusWord#` 1##) bi#) ==# 0#) | True = isTrue# ((testBitWord# (indexBigNat# bn li#) bi#) ==# 0#) where - (# li#, bi# #) = quotRemInt# i# GMP_LIMB_BITS# + !(# li#, bi# #) = quotRemInt# i# GMP_LIMB_BITS# nx# = sizeofBigNat# bn allZ 0# = True @@ -1108,7 +1108,7 @@ shiftLBigNat x@(BN# xba#) n# = runS $ do where xn# = sizeofBigNat# x yn# = xn# +# nlimbs# +# (nbits# /=# 0#) - (# nlimbs#, nbits# #) = quotRemInt# n# GMP_LIMB_BITS# + !(# nlimbs#, nbits# #) = quotRemInt# n# GMP_LIMB_BITS# @@ -1693,7 +1693,7 @@ resizeMutBigNat# (MBN# mba0#) nsz# s (# s'', mba# #) -> (# s'', MBN# mba# #) where bsz# = nsz# `uncheckedIShiftL#` GMP_LIMB_SHIFT# - (# s', n# #) = getSizeofMutableByteArray# mba0# s + !(# s', n# #) = getSizeofMutableByteArray# mba0# s shrinkMutBigNat# :: MutBigNat s -> GmpSize# -> State# s -> State# s shrinkMutBigNat# (MBN# mba0#) nsz# s @@ -1701,13 +1701,13 @@ shrinkMutBigNat# (MBN# mba0#) nsz# s | True = shrinkMutableByteArray# mba0# bsz# s' where bsz# = nsz# `uncheckedIShiftL#` GMP_LIMB_SHIFT# - (# s', n# #) = getSizeofMutableByteArray# mba0# s + !(# s', n# #) = getSizeofMutableByteArray# mba0# s unsafeSnocFreezeBigNat# :: MutBigNat s -> GmpLimb# -> S s BigNat unsafeSnocFreezeBigNat# mbn0@(MBN# mba0#) limb# s = go s' where n# = nb0# `uncheckedIShiftRL#` GMP_LIMB_SHIFT# - (# s', nb0# #) = getSizeofMutableByteArray# mba0# s + !(# s', nb0# #) = getSizeofMutableByteArray# mba0# s go = do (MBN# mba#) <- resizeMutBigNat# mbn0 (n# +# 1#) _ <- svoid (writeWordArray# mba# n# limb#) @@ -1721,8 +1721,8 @@ unsafeRenormFreezeBigNat# mbn s | isTrue# (n# ==# n0#) = (unsafeFreezeBigNat# mbn) s'' | True = (unsafeShrinkFreezeBigNat# mbn n#) s'' where - (# s', n0# #) = getSizeofMutBigNat# mbn s - (# s'', n# #) = normSizeofMutBigNat'# mbn n0# s' + !(# s', n0# #) = getSizeofMutBigNat# mbn s + !(# s'', n# #) = normSizeofMutBigNat'# mbn n0# s' -- | Shrink MBN unsafeShrinkFreezeBigNat# :: MutBigNat s -> GmpSize# -> S s BigNat @@ -1752,7 +1752,7 @@ copyWordArray# src src_ofs dst dst_ofs len normSizeofMutBigNat# :: MutBigNat s -> State# s -> (# State# s, Int# #) normSizeofMutBigNat# mbn@(MBN# mba) s = normSizeofMutBigNat'# mbn sz# s' where - (# s', n# #) = getSizeofMutableByteArray# mba s + !(# s', n# #) = getSizeofMutableByteArray# mba s sz# = n# `uncheckedIShiftRA#` GMP_LIMB_SHIFT# -- | Find most-significant non-zero limb and return its index-position @@ -1783,13 +1783,13 @@ byteArrayToBigNat# ba# n0# | isTrue# (baszr# ==# 0#) -- i.e. ba# is multiple of limb-size , isTrue# (baszq# ==# n#) = (BN# ba#) | True = runS $ \s -> - let (# s', mbn@(MBN# mba#) #) = newBigNat# n# s - (# s'', ba_sz# #) = getSizeofMutableByteArray# mba# s' + let !(# s', mbn@(MBN# mba#) #) = newBigNat# n# s + !(# s'', ba_sz# #) = getSizeofMutableByteArray# mba# s' go = do _ <- svoid (copyByteArray# ba# 0# mba# 0# ba_sz# ) unsafeFreezeBigNat# mbn in go s'' where - (# baszq#, baszr# #) = quotRemInt# (sizeofByteArray# ba#) GMP_LIMB_BYTES# + !(# baszq#, baszr# #) = quotRemInt# (sizeofByteArray# ba#) GMP_LIMB_BYTES# n# = fmssl (n0# -# 1#) @@ -1914,7 +1914,7 @@ isValidBigNat# (BN# ba#) sz# = sizeofByteArray# ba# - (# szq#, szr# #) = quotRemInt# sz# GMP_LIMB_BYTES# + !(# szq#, szr# #) = quotRemInt# sz# GMP_LIMB_BYTES# -- | Version of 'nextPrimeInteger' operating on 'BigNat's -- diff --git a/testsuite/tests/deSugar/should_compile/T10662.stderr b/testsuite/tests/deSugar/should_compile/T10662.stderr index d81891619c..f27fc977b6 100644 --- a/testsuite/tests/deSugar/should_compile/T10662.stderr +++ b/testsuite/tests/deSugar/should_compile/T10662.stderr @@ -2,4 +2,4 @@ T10662.hs:3:3: warning: [-Wunused-do-bind (in -Wall)] A do-notation statement discarded a result of type ‘[Char]’ Suppress this warning by saying - ‘_ <- ($) return let a = "hello" in a’ + ‘_ <- return $ let a = "hello" in a’ diff --git a/testsuite/tests/dependent/should_compile/RaeJobTalk.hs b/testsuite/tests/dependent/should_compile/RaeJobTalk.hs index 2f0edf8593..e5c2002e0c 100644 --- a/testsuite/tests/dependent/should_compile/RaeJobTalk.hs +++ b/testsuite/tests/dependent/should_compile/RaeJobTalk.hs @@ -82,7 +82,7 @@ data TyCon (a :: k) where Arrow :: TyCon (->) TYPE :: TyCon TYPE RuntimeRep :: TyCon RuntimeRep - PtrRepLifted' :: TyCon 'PtrRepLifted + LiftedRep' :: TyCon 'LiftedRep -- If extending, add to eqTyCon too eqTyCon :: TyCon a -> TyCon b -> Maybe (a :~~: b) @@ -94,7 +94,7 @@ eqTyCon Maybe Maybe = Just HRefl eqTyCon Arrow Arrow = Just HRefl eqTyCon TYPE TYPE = Just HRefl eqTyCon RuntimeRep RuntimeRep = Just HRefl -eqTyCon PtrRepLifted' PtrRepLifted' = Just HRefl +eqTyCon LiftedRep' LiftedRep' = Just HRefl eqTyCon _ _ = Nothing -- Check whether or not a type is really a plain old tycon; @@ -212,7 +212,7 @@ instance TyConAble [] where tyCon = List instance TyConAble Maybe where tyCon = Maybe instance TyConAble (->) where tyCon = Arrow instance TyConAble TYPE where tyCon = TYPE -instance TyConAble 'PtrRepLifted where tyCon = PtrRepLifted' +instance TyConAble 'LiftedRep where tyCon = LiftedRep' instance TyConAble RuntimeRep where tyCon = RuntimeRep -- Can't just define Typeable the way we want, because the instances diff --git a/testsuite/tests/dependent/should_fail/T11473.stderr b/testsuite/tests/dependent/should_fail/T11473.stderr index 431c2dff92..3252452eb2 100644 --- a/testsuite/tests/dependent/should_fail/T11473.stderr +++ b/testsuite/tests/dependent/should_fail/T11473.stderr @@ -1,6 +1,6 @@ T11473.hs:19:7: error: - A representation-polymorphic type is not allowed here: + A levity-polymorphic type is not allowed here: Type: a Kind: TYPE r In the type of binder ‘x’ diff --git a/testsuite/tests/deriving/should_fail/T12512.hs b/testsuite/tests/deriving/should_fail/T12512.hs index 87c3d668df..4d4e52c06c 100644 --- a/testsuite/tests/deriving/should_fail/T12512.hs +++ b/testsuite/tests/deriving/should_fail/T12512.hs @@ -1,14 +1,13 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UnboxedSums #-} {-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE TypeInType #-} module T12512 where import GHC.Exts -class Wat1 (a :: TYPE 'UnboxedTupleRep) +class Wat1 (a :: TYPE ('TupleRep ['LiftedRep, 'LiftedRep])) deriving instance Wat1 (# a, b #) -class Wat2 (a :: TYPE 'UnboxedSumRep) +class Wat2 (a :: TYPE ('SumRep ['LiftedRep, 'LiftedRep])) deriving instance Wat2 (# a | b #) diff --git a/testsuite/tests/deriving/should_fail/T12512.stderr b/testsuite/tests/deriving/should_fail/T12512.stderr index 48f0eae205..a62cda6b99 100644 --- a/testsuite/tests/deriving/should_fail/T12512.stderr +++ b/testsuite/tests/deriving/should_fail/T12512.stderr @@ -1,10 +1,10 @@ -T12512.hs:11:1: error: +T12512.hs:10:1: error: • Can't make a derived instance of ‘Wat1 (# a, b #)’: The last argument of the instance cannot be an unboxed tuple • In the stand-alone deriving instance for ‘Wat1 (# a, b #)’ -T12512.hs:14:1: error: +T12512.hs:13:1: error: • Can't make a derived instance of ‘Wat2 (# a | b #)’: The last argument of the instance cannot be an unboxed sum • In the stand-alone deriving instance for ‘Wat2 (# a | b #)’ diff --git a/testsuite/tests/ghci/scripts/GhciKinds.stdout b/testsuite/tests/ghci/scripts/GhciKinds.stdout index 3556e621a4..5431bbc17d 100644 --- a/testsuite/tests/ghci/scripts/GhciKinds.stdout +++ b/testsuite/tests/ghci/scripts/GhciKinds.stdout @@ -10,4 +10,8 @@ F (Maybe Bool) :: * forall a. F (Maybe a) :: * = Char $(unboxedTupleT 2) :: forall (k0 :: RuntimeRep) (k1 :: RuntimeRep). - TYPE k0 -> TYPE k1 -> TYPE 'UnboxedTupleRep + TYPE k0 + -> TYPE k1 + -> TYPE + ('TupleRep + ((':) RuntimeRep k0 ((':) RuntimeRep k1 ('[] RuntimeRep)))) diff --git a/testsuite/tests/ghci/scripts/T9140.stdout b/testsuite/tests/ghci/scripts/T9140.stdout index 6456067f59..85406d04b6 100644 --- a/testsuite/tests/ghci/scripts/T9140.stdout +++ b/testsuite/tests/ghci/scripts/T9140.stdout @@ -1,13 +1,11 @@ <interactive>:2:5: error: - You can't mix polymorphic and unlifted bindings - a = (# 1 #) - Probable fix: add a type signature + You can't mix polymorphic and unlifted bindings: a = (# 1 #) + Probable fix: add a type signature <interactive>:3:5: error: - You can't mix polymorphic and unlifted bindings - a = (# 1, 3 #) - Probable fix: add a type signature + You can't mix polymorphic and unlifted bindings: a = (# 1, 3 #) + Probable fix: add a type signature <interactive>:1:1: error: GHCi can't bind a variable of unlifted type: diff --git a/testsuite/tests/patsyn/should_fail/UnliftedPSBind.hs b/testsuite/tests/patsyn/should_fail/UnliftedPSBind.hs new file mode 100644 index 0000000000..9cb38ed404 --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/UnliftedPSBind.hs @@ -0,0 +1,12 @@ + +-- This is testing the printing of the builder really. +{-# LANGUAGE MagicHash, PatternSynonyms #-} +{-# OPTIONS_GHC -Werror -Wunbanged-strict-patterns #-} +module UnliftedPSBind where + +import GHC.Exts + +pattern P x = I# x + +x = () + where P x = P 4# diff --git a/testsuite/tests/patsyn/should_fail/UnliftedPSBind.stderr b/testsuite/tests/patsyn/should_fail/UnliftedPSBind.stderr new file mode 100644 index 0000000000..6b6b97710e --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/UnliftedPSBind.stderr @@ -0,0 +1,8 @@ + +UnliftedPSBind.hs:12:9: warning: [-Wunbanged-strict-patterns (in -Wextra)] + Pattern bindings containing unlifted types should use + an outermost bang pattern: + P x = P 4# + +<no location info>: error: +Failing due to -Werror. diff --git a/testsuite/tests/patsyn/should_fail/all.T b/testsuite/tests/patsyn/should_fail/all.T index cb23b3fb2a..50a3eea6c1 100644 --- a/testsuite/tests/patsyn/should_fail/all.T +++ b/testsuite/tests/patsyn/should_fail/all.T @@ -33,3 +33,4 @@ test('T11265', normal, compile_fail, ['']) test('T11667', normal, compile_fail, ['']) test('T12165', normal, compile_fail, ['']) test('T12819', normal, compile_fail, ['']) +test('UnliftedPSBind', normal, compile_fail, ['']) diff --git a/testsuite/tests/patsyn/should_fail/unboxed-bind.hs b/testsuite/tests/patsyn/should_fail/unboxed-bind.hs index ef1b070d49..6be73839f2 100644 --- a/testsuite/tests/patsyn/should_fail/unboxed-bind.hs +++ b/testsuite/tests/patsyn/should_fail/unboxed-bind.hs @@ -1,4 +1,5 @@ {-# LANGUAGE PatternSynonyms, MagicHash #-} +{-# OPTIONS_GHC -Wunbanged-strict-patterns -Werror=unbanged-strict-patterns #-} module ShouldFail where import GHC.Base diff --git a/testsuite/tests/patsyn/should_fail/unboxed-bind.stderr b/testsuite/tests/patsyn/should_fail/unboxed-bind.stderr index 17ca7afd3b..8f20f91be9 100644 --- a/testsuite/tests/patsyn/should_fail/unboxed-bind.stderr +++ b/testsuite/tests/patsyn/should_fail/unboxed-bind.stderr @@ -1,6 +1,8 @@ -unboxed-bind.hs:10:11: - Pattern bindings containing unlifted types should use an outermost bang pattern: +unboxed-bind.hs:11:11: warning: [-Wunbanged-strict-patterns (in -Wextra)] + Pattern bindings containing unlifted types should use + an outermost bang pattern: P arg = x - In the expression: let P arg = x in arg - In an equation for ‘f’: f x = let P arg = x in arg + +<no location info>: error: +Failing due to -Werror. diff --git a/testsuite/tests/quasiquotation/T7918.stdout b/testsuite/tests/quasiquotation/T7918.stdout index 4dff68d1ce..96482371a2 100644 --- a/testsuite/tests/quasiquotation/T7918.stdout +++ b/testsuite/tests/quasiquotation/T7918.stdout @@ -1,10 +1,5 @@ -(True, T7918B.hs:6:11-14) (id, T7918B.hs:7:11-14) -(True, T7918B.hs:7:11-14) -(True, T7918B.hs:8:11-14) (||, T7918B.hs:8:11-14) -(False, T7918B.hs:8:11-14) -(False, T7918B.hs:9:11-14) (undefined, T7918B.hs:11:7-15) (Bool, T7918B.hs:11:24-27) (undefined, T7918B.hs:12:7-15) @@ -25,6 +20,3 @@ (undefined, T7918B.hs:18:16-24) (y, T7918B.hs:19:9-12) (undefined, T7918B.hs:19:16-24) -(Module, <no location info>) -(TrNameS, <no location info>) -(TrNameS, <no location info>) diff --git a/testsuite/tests/simplCore/should_compile/T9400.stderr b/testsuite/tests/simplCore/should_compile/T9400.stderr index d4b7898d83..bab1751a86 100644 --- a/testsuite/tests/simplCore/should_compile/T9400.stderr +++ b/testsuite/tests/simplCore/should_compile/T9400.stderr @@ -46,7 +46,7 @@ main = @ () (putStrLn (unpackCString# "efg"#)) (Control.Exception.Base.patError - @ 'PtrRepLifted @ (IO ()) "T9400.hs:(17,5)-(18,29)|case"#)))) + @ 'LiftedRep @ (IO ()) "T9400.hs:(17,5)-(18,29)|case"#)))) diff --git a/testsuite/tests/simplCore/should_compile/spec-inline.stderr b/testsuite/tests/simplCore/should_compile/spec-inline.stderr index 732265a8f6..e7fc531a43 100644 --- a/testsuite/tests/simplCore/should_compile/spec-inline.stderr +++ b/testsuite/tests/simplCore/should_compile/spec-inline.stderr @@ -35,7 +35,7 @@ Roman.foo3 :: Int [GblId, Str=x] Roman.foo3 = Control.Exception.Base.patError - @ 'GHC.Types.PtrRepLifted + @ 'GHC.Types.LiftedRep @ Int "spec-inline.hs:(19,5)-(29,25)|function go"# diff --git a/testsuite/tests/th/T12403.stdout b/testsuite/tests/th/T12403.stdout index 9b75e8b272..24e222a732 100644 --- a/testsuite/tests/th/T12403.stdout +++ b/testsuite/tests/th/T12403.stdout @@ -1 +1,5 @@ -data Main.T = Main.T ((# , #) GHC.Types.Int GHC.Types.Int) +data Main.T + = Main.T ((# , #) GHC.Types.Int + GHC.Types.Int :: GHC.Prim.TYPE (GHC.Types.TupleRep (GHC.Types.: GHC.Types.LiftedRep + (GHC.Types.: GHC.Types.LiftedRep + GHC.Types.[])))) diff --git a/testsuite/tests/th/T12478_1.stdout b/testsuite/tests/th/T12478_1.stdout index 8437f925d5..f94db5992d 100644 --- a/testsuite/tests/th/T12478_1.stdout +++ b/testsuite/tests/th/T12478_1.stdout @@ -1 +1 @@ -TyConI (DataD [] Main.T [] Nothing [NormalC Main.T [(Bang NoSourceUnpackedness NoSourceStrictness,AppT (AppT (UnboxedSumT 2) (ConT GHC.Types.Int)) (ConT GHC.Types.Char))]] []) +TyConI (DataD [] Main.T [] Nothing [NormalC Main.T [(Bang NoSourceUnpackedness NoSourceStrictness,SigT (AppT (AppT (UnboxedSumT 2) (ConT GHC.Types.Int)) (ConT GHC.Types.Char)) (AppT (ConT GHC.Prim.TYPE) (AppT (ConT GHC.Types.SumRep) (AppT (AppT (ConT GHC.Types.:) (ConT GHC.Types.LiftedRep)) (AppT (AppT (ConT GHC.Types.:) (ConT GHC.Types.LiftedRep)) (ConT GHC.Types.[]))))))]] []) diff --git a/testsuite/tests/th/T5358.stderr b/testsuite/tests/th/T5358.stderr index d9485cebb7..4bfc53a78e 100644 --- a/testsuite/tests/th/T5358.stderr +++ b/testsuite/tests/th/T5358.stderr @@ -1,11 +1,11 @@ T5358.hs:14:12: error: - Exception when trying to run compile-time code: - runTest called error: forall (t_0 :: *) . t_0 -> GHC.Types.Bool -CallStack (from ImplicitParams): + • Exception when trying to run compile-time code: + runTest called error: forall (t_0 :: *) . t_0 -> GHC.Types.Bool +CallStack (from HasCallStack): error, called at T5358.hs:15:18 in main:T5358 - Code: do VarI _ t _ <- reify (mkName "prop_x1") - ($) error ((++) "runTest called error: " pprint t) - In the untyped splice: - $(do VarI _ t _ <- reify (mkName "prop_x1") - error $ ("runTest called error: " ++ pprint t)) + Code: do VarI _ t _ <- reify (mkName "prop_x1") + error $ ("runTest called error: " ++ pprint t) + • In the untyped splice: + $(do VarI _ t _ <- reify (mkName "prop_x1") + error $ ("runTest called error: " ++ pprint t)) diff --git a/testsuite/tests/th/T5976.stderr b/testsuite/tests/th/T5976.stderr index 507d9d8b8d..f4e9568927 100644 --- a/testsuite/tests/th/T5976.stderr +++ b/testsuite/tests/th/T5976.stderr @@ -2,6 +2,6 @@ T5976.hs:1:1: error: Exception when trying to run compile-time code: bar -CallStack (from ImplicitParams): +CallStack (from HasCallStack): error, called at T5976.hs:3:21 in main:Main - Code: error ((++) "foo " error "bar") + Code: error ("foo " ++ error "bar") diff --git a/testsuite/tests/th/T8987.stderr b/testsuite/tests/th/T8987.stderr index 1af2e29b7f..7b5f400f6f 100644 --- a/testsuite/tests/th/T8987.stderr +++ b/testsuite/tests/th/T8987.stderr @@ -2,7 +2,7 @@ T8987.hs:1:1: error: Exception when trying to run compile-time code: Prelude.undefined -CallStack (from ImplicitParams): - error, called at libraries/base/GHC/Err.hs:43:14 in base:GHC.Err +CallStack (from HasCallStack): + error, called at libraries/base/GHC/Err.hs:79:14 in base:GHC.Err undefined, called at T8987.hs:6:23 in main:T8987 - Code: (>>) reportWarning ['1', undefined] return [] + Code: reportWarning ['1', undefined] >> return [] diff --git a/testsuite/tests/typecheck/should_compile/T11723.hs b/testsuite/tests/typecheck/should_compile/T11723.hs new file mode 100644 index 0000000000..1933024f2e --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T11723.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeInType #-} +module Example where + +import Data.Typeable +import GHC.Exts + +data Wat (a :: TYPE ('TupleRep '[])) = Wat a diff --git a/testsuite/tests/typecheck/should_compile/T11736.hs b/testsuite/tests/typecheck/should_compile/T11736.hs new file mode 100644 index 0000000000..8bcbc3e06b --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T11736.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE UnboxedTuples #-} + +module T11736 where + +import Data.Proxy + +foo :: Proxy (#,#) +foo = Proxy diff --git a/testsuite/tests/typecheck/should_compile/T12987.hs b/testsuite/tests/typecheck/should_compile/T12987.hs new file mode 100644 index 0000000000..0997985601 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T12987.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeInType #-} + +module T12987 where + +import GHC.Exts + +class NUM (a :: TYPE rep) where add :: a -> a -> a diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T index b70ab83b34..c5e9163bbe 100644 --- a/testsuite/tests/typecheck/should_compile/all.T +++ b/testsuite/tests/typecheck/should_compile/all.T @@ -565,3 +565,6 @@ test('T12919', expect_broken(12919), compile, ['']) test('T12936', normal, compile, ['']) test('T13050', normal, compile, ['-fdefer-type-errors']) test('T13083', normal, compile, ['']) +test('T11723', normal, compile, ['']) +test('T12987', normal, compile, ['']) +test('T11736', normal, compile, ['']) diff --git a/testsuite/tests/typecheck/should_fail/BadUnboxedTuple.hs b/testsuite/tests/typecheck/should_fail/BadUnboxedTuple.hs deleted file mode 100644 index 2935416538..0000000000 --- a/testsuite/tests/typecheck/should_fail/BadUnboxedTuple.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE TypeFamilies, KindSignatures, TypeInType #-} - -module BadUnboxedTuple where - -import GHC.Exts - -type family F :: TYPE UnboxedTupleRep - -foo :: F -> () -foo _ = () diff --git a/testsuite/tests/typecheck/should_fail/BadUnboxedTuple.stderr b/testsuite/tests/typecheck/should_fail/BadUnboxedTuple.stderr deleted file mode 100644 index 7c5ad5762f..0000000000 --- a/testsuite/tests/typecheck/should_fail/BadUnboxedTuple.stderr +++ /dev/null @@ -1,6 +0,0 @@ - -BadUnboxedTuple.hs:10:5: error: - The type ‘F’ is not an unboxed tuple, - and yet its kind suggests that it has the representation - of an unboxed tuple. This is not allowed. - In a wildcard pattern diff --git a/testsuite/tests/typecheck/should_fail/LevPolyBounded.hs b/testsuite/tests/typecheck/should_fail/LevPolyBounded.hs new file mode 100644 index 0000000000..0607956784 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/LevPolyBounded.hs @@ -0,0 +1,11 @@ +-- inspired by comment:25 on #12708 + +{-# LANGUAGE TypeInType #-} + +module LevPolyBounded where + +import GHC.Exts + +class XBounded (a :: TYPE r) where + minBound :: a + maxBound :: a diff --git a/testsuite/tests/typecheck/should_fail/LevPolyBounded.stderr b/testsuite/tests/typecheck/should_fail/LevPolyBounded.stderr new file mode 100644 index 0000000000..21ae68ab85 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/LevPolyBounded.stderr @@ -0,0 +1,5 @@ + +LevPolyBounded.hs:10:15: error: + • Expected a type, but ‘a’ has kind ‘TYPE r’ + • In the type signature: LevPolyBounded.minBound :: a + In the class declaration for ‘XBounded’ diff --git a/testsuite/tests/typecheck/should_fail/StrictBinds.hs b/testsuite/tests/typecheck/should_fail/StrictBinds.hs new file mode 100644 index 0000000000..bd951f96b1 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/StrictBinds.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE MagicHash #-} + +module StrictBinds where + +import GHC.Exts + +foo = let x = 3# +# y + y = x in + True diff --git a/testsuite/tests/typecheck/should_fail/StrictBinds.stderr b/testsuite/tests/typecheck/should_fail/StrictBinds.stderr new file mode 100644 index 0000000000..082d71176a --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/StrictBinds.stderr @@ -0,0 +1,5 @@ + +StrictBinds.hs:7:11: error: + Recursive bindings for unlifted types aren't allowed: + x = 3# +# y + y = x diff --git a/testsuite/tests/typecheck/should_fail/T11723.hs b/testsuite/tests/typecheck/should_fail/T11723.hs deleted file mode 100644 index 4761cc4131..0000000000 --- a/testsuite/tests/typecheck/should_fail/T11723.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -module Example where - -import Data.Typeable -import GHC.Exts - -data Wat (a :: TYPE 'UnboxedTupleRep) = Wat a diff --git a/testsuite/tests/typecheck/should_fail/T11723.stderr b/testsuite/tests/typecheck/should_fail/T11723.stderr deleted file mode 100644 index b63a182d2c..0000000000 --- a/testsuite/tests/typecheck/should_fail/T11723.stderr +++ /dev/null @@ -1,7 +0,0 @@ - -T11723.hs:8:41: error: - • The type ‘a’ is not an unboxed tuple, - and yet its kind suggests that it has the representation - of an unboxed tuple. This is not allowed. - • In the definition of data constructor ‘Wat’ - In the data type declaration for ‘Wat’ diff --git a/testsuite/tests/typecheck/should_fail/T11724.stderr b/testsuite/tests/typecheck/should_fail/T11724.stderr index 2971b27597..dbdbb6fdef 100644 --- a/testsuite/tests/typecheck/should_fail/T11724.stderr +++ b/testsuite/tests/typecheck/should_fail/T11724.stderr @@ -1,6 +1,6 @@ T11724.hs:7:44: error: - • A representation-polymorphic type is not allowed here: + • A levity-polymorphic type is not allowed here: Type: a Kind: TYPE r • In the definition of data constructor ‘Foo’ diff --git a/testsuite/tests/typecheck/should_fail/T12973.hs b/testsuite/tests/typecheck/should_fail/T12973.hs new file mode 100644 index 0000000000..624d24be24 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T12973.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE RebindableSyntax, TypeInType, ExplicitForAll #-} + +module T12973 where + +import qualified Prelude as P +import GHC.Exts + +class Num (a :: TYPE r) where + (+) :: a -> a -> a + fromInteger :: P.Integer -> a + +foo :: forall (a :: TYPE r). Num a => a +foo = 3 + 4 + + diff --git a/testsuite/tests/typecheck/should_fail/T12973.stderr b/testsuite/tests/typecheck/should_fail/T12973.stderr new file mode 100644 index 0000000000..a6d97009cd --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T12973.stderr @@ -0,0 +1,12 @@ + +T12973.hs:13:7: error: + A levity-polymorphic type is not allowed here: + Type: a + Kind: TYPE r + In the type of expression: 3 + +T12973.hs:13:11: error: + A levity-polymorphic type is not allowed here: + Type: a + Kind: TYPE r + In the type of expression: 4 diff --git a/testsuite/tests/typecheck/should_fail/T13105.hs b/testsuite/tests/typecheck/should_fail/T13105.hs new file mode 100644 index 0000000000..44384dc19d --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T13105.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE UnicodeSyntax, MagicHash, TypeInType, TypeFamilies #-} + +-- from Conal Elliott +-- Actually, this *should* work. But I want to put it in the testsuite +-- as a succeeding "compile_fail" test to make sure that we don't panic. + +module RepRep where + +import GHC.Exts + +type family RepRep a ∷ RuntimeRep + +class HasRep a where + type Rep a ∷ TYPE (RepRep a) + repr ∷ a → Rep a + abst ∷ Rep a → a + +type instance RepRep Int = IntRep + +instance HasRep Int where + type Rep Int = Int# + abst n = I# n + repr (I# n) = n diff --git a/testsuite/tests/typecheck/should_fail/T13105.stderr b/testsuite/tests/typecheck/should_fail/T13105.stderr new file mode 100644 index 0000000000..c54327ef70 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T13105.stderr @@ -0,0 +1,6 @@ + +T13105.hs:22:8: error: + A levity-polymorphic type is not allowed here: + Type: Rep Int + Kind: TYPE (RepRep Int) + In the type of binder ‘n’ diff --git a/testsuite/tests/typecheck/should_fail/T2806.hs b/testsuite/tests/typecheck/should_fail/T2806.hs index 6ada5d83fb..ac95542c94 100644 --- a/testsuite/tests/typecheck/should_fail/T2806.hs +++ b/testsuite/tests/typecheck/should_fail/T2806.hs @@ -1,5 +1,6 @@ {-# LANGUAGE MagicHash #-} +{-# OPTIONS_GHC -Wunbanged-strict-patterns #-} -- Trac #2806 @@ -10,4 +11,3 @@ import GHC.Base foo :: Int foo = 3 where (I# _x) = 4 - diff --git a/testsuite/tests/typecheck/should_fail/T2806.stderr b/testsuite/tests/typecheck/should_fail/T2806.stderr index 25cc8e65a0..02a4d81c15 100644 --- a/testsuite/tests/typecheck/should_fail/T2806.stderr +++ b/testsuite/tests/typecheck/should_fail/T2806.stderr @@ -1,9 +1,5 @@ -T2806.hs:12:11: - Pattern bindings containing unlifted types should use an outermost bang pattern: +T2806.hs:13:11: warning: [-Wunbanged-strict-patterns (in -Wextra)] + Pattern bindings containing unlifted types should use + an outermost bang pattern: (I# _x) = 4 - In an equation for ‘foo’: - foo - = 3 - where - (I# _x) = 4 diff --git a/testsuite/tests/typecheck/should_fail/T6078.stderr b/testsuite/tests/typecheck/should_fail/T6078.stderr index b45363bdc3..62a4210443 100644 --- a/testsuite/tests/typecheck/should_fail/T6078.stderr +++ b/testsuite/tests/typecheck/should_fail/T6078.stderr @@ -1,11 +1,5 @@ T6078.hs:8:10: error: - You can't mix polymorphic and unlifted bindings + You can't mix polymorphic and unlifted bindings: ip1p@(Ptr ip1) = Ptr ip0 `plusPtr` len - Probable fix: add a type signature - In the expression: - let ip1p@(Ptr ip1) = Ptr ip0 `plusPtr` len in ip1p - In the expression: - \ fpbuf ip0 ipe s0 -> let ip1p@(Ptr ip1) = ... in ip1p - In an equation for ‘byteStringSlice’: - byteStringSlice len = \ fpbuf ip0 ipe s0 -> let ... in ip1p + Probable fix: add a type signature diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T index c490fec10e..9931037e4e 100644 --- a/testsuite/tests/typecheck/should_fail/all.T +++ b/testsuite/tests/typecheck/should_fail/all.T @@ -187,7 +187,7 @@ test('tcfail199', normal, compile_fail, ['']) test('tcfail200', normal, compile_fail, ['']) test('tcfail201', normal, compile_fail, ['']) test('tcfail202', normal, compile_fail, ['']) -test('tcfail203', normal, compile_fail, ['']) +test('tcfail203', normal, compile, ['']) test('tcfail203a', normal, compile_fail, ['']) test('tcfail204', normal, compile_fail, ['']) test('tcfail206', normal, compile_fail, ['']) @@ -204,7 +204,7 @@ test('T2994', normal, compile_fail, ['']) test('T3155', normal, compile_fail, ['']) test('T3176', normal, compile_fail, ['']) test('T1633', normal, compile_fail, ['']) -test('T2806', normal, compile_fail, ['']) +test('T2806', normal, compile, ['']) test('T3323', normal, compile_fail, ['']) test('T3406', normal, compile_fail, ['']) test('T3540', normal, compile_fail, ['']) @@ -406,9 +406,7 @@ test('T11563', normal, compile_fail, ['']) test('T11541', normal, compile_fail, ['']) test('T11313', normal, compile_fail, ['']) test('T11623', normal, compile_fail, ['']) -test('T11723', normal, compile_fail, ['']) test('T11724', normal, compile_fail, ['']) -test('BadUnboxedTuple', normal, compile_fail, ['']) test('T11698', normal, compile_fail, ['']) test('T11947a', normal, compile_fail, ['']) test('T11948', normal, compile_fail, ['']) @@ -435,3 +433,7 @@ test('T12042', extra_clean(['T12042a.hi', 'T12042a.o', 'T12042.hi-boot', 'T12042 test('T12966', normal, compile_fail, ['']) test('T12837', normal, compile_fail, ['']) test('T12921', normal, compile_fail, ['']) +test('T12973', normal, compile_fail, ['']) +test('StrictBinds', normal, compile_fail, ['']) +test('T13105', normal, compile_fail, ['']) +test('LevPolyBounded', normal, compile_fail, ['']) diff --git a/testsuite/tests/typecheck/should_fail/tcfail203.hs b/testsuite/tests/typecheck/should_fail/tcfail203.hs index 7f51dae3b5..096cf5796b 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail203.hs +++ b/testsuite/tests/typecheck/should_fail/tcfail203.hs @@ -1,6 +1,7 @@ -- trac #2806 {-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns #-} +{-# OPTIONS_GHC -Wunbanged-strict-patterns #-} module Foo where diff --git a/testsuite/tests/typecheck/should_fail/tcfail203.stderr b/testsuite/tests/typecheck/should_fail/tcfail203.stderr index 21454e345d..d9f7087229 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail203.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail203.stderr @@ -1,36 +1,40 @@ -tcfail203.hs:28:11: - Pattern bindings containing unlifted types should use an outermost bang pattern: +tcfail203.hs:29:11: warning: [-Wunbanged-strict-patterns (in -Wextra)] + Pattern bindings containing unlifted types should use + an outermost bang pattern: (I# x) = 5 - In an equation for ‘fail2’: - fail2 - = 'a' - where - (I# x) = 5 - -tcfail203.hs:31:11: - Pattern bindings containing unlifted types should use an outermost bang pattern: + +tcfail203.hs:32:11: warning: [-Wunbanged-strict-patterns (in -Wextra)] + Pattern bindings containing unlifted types should use + an outermost bang pattern: (b, I# x) = (True, 5) - In an equation for ‘fail3’: - fail3 - = 'a' - where - (b, I# x) = (True, 5) - -tcfail203.hs:40:11: - Pattern bindings containing unlifted types should use an outermost bang pattern: + +tcfail203.hs:35:11: warning: [-Wunbanged-strict-patterns (in -Wextra)] + Pattern bindings containing unlifted types should use + an outermost bang pattern: + (# b, I# x #) = (# True, 5 #) + +tcfail203.hs:38:11: warning: [-Wunbanged-strict-patterns (in -Wextra)] + Pattern bindings containing unlifted types should use + an outermost bang pattern: + (# b, x #) = (# True, 5# #) + +tcfail203.hs:41:11: warning: [-Wunbanged-strict-patterns (in -Wextra)] + Pattern bindings containing unlifted types should use + an outermost bang pattern: (I# !x) = 5 - In an equation for ‘fail6’: - fail6 - = 'a' - where - (I# !x) = 5 - -tcfail203.hs:43:11: - Pattern bindings containing unlifted types should use an outermost bang pattern: + +tcfail203.hs:44:11: warning: [-Wunbanged-strict-patterns (in -Wextra)] + Pattern bindings containing unlifted types should use + an outermost bang pattern: (b, !(I# x)) = (True, 5) - In an equation for ‘fail7’: - fail7 - = 'a' - where - (b, !(I# x)) = (True, 5) + +tcfail203.hs:47:11: warning: [-Wunbanged-strict-patterns (in -Wextra)] + Pattern bindings containing unlifted types should use + an outermost bang pattern: + (# b, !(I# x) #) = (# True, 5 #) + +tcfail203.hs:50:11: warning: [-Wunbanged-strict-patterns (in -Wextra)] + Pattern bindings containing unlifted types should use + an outermost bang pattern: + (# b, !x #) = (# True, 5# #) diff --git a/testsuite/tests/typecheck/should_fail/tcfail203a.stderr b/testsuite/tests/typecheck/should_fail/tcfail203a.stderr index 272ff4254e..153a9259ba 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail203a.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail203a.stderr @@ -1,6 +1,5 @@ -tcfail203a.hs:10:16: - A lazy (~) pattern cannot contain unlifted types: ~(c, (I# x)) - In the pattern: ~(c, (I# x)) - In the pattern: (b, ~(c, (I# x))) - In the pattern: !(b, ~(c, (I# x))) +tcfail203a.hs:10:17: error: + A lazy (~) pattern cannot bind variables of unlifted type. + Unlifted variables: + x :: Int# diff --git a/testsuite/tests/typecheck/should_run/EtaExpandLevPoly.hs b/testsuite/tests/typecheck/should_run/EtaExpandLevPoly.hs new file mode 100644 index 0000000000..e912411209 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/EtaExpandLevPoly.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE UnboxedTuples, MagicHash, GADTs, TypeInType, ExplicitForAll #-} + + +module Main where + +import GHC.Exts + +data G a where + MkG :: G (TupleRep [LiftedRep, IntRep]) + +-- tests that we don't eta-expand functions that are levity-polymorphic +-- see CoreArity.mkEtaWW +foo :: forall a (b :: TYPE a). G a -> b -> b +foo MkG = (\x -> x) :: forall (c :: TYPE (TupleRep [LiftedRep, IntRep])). c -> c + +data H a where + MkH :: H IntRep + +-- tests that we don't push coercions that make args levity-polymorphic +-- see Simplify.simplCast +bar :: forall (r :: RuntimeRep) (a :: TYPE r). H r -> (a -> a -> (# a, a #)) -> a -> (# a, a #) +bar MkH = (\f x -> f x x) :: forall (b :: TYPE IntRep). (b -> b -> (# b, b #)) -> b -> (# b, b #) + +main :: IO () +main = do + let (# b, x #) = foo MkG (# True, 3# #) + print b + print (I# x) + + let (# y, z #) = bar MkH (#,#) 8# + print (I# y) + print (I# z) diff --git a/testsuite/tests/typecheck/should_run/EtaExpandLevPoly.stdout b/testsuite/tests/typecheck/should_run/EtaExpandLevPoly.stdout new file mode 100644 index 0000000000..97c6c910ed --- /dev/null +++ b/testsuite/tests/typecheck/should_run/EtaExpandLevPoly.stdout @@ -0,0 +1,4 @@ +True +3 +8 +8 diff --git a/testsuite/tests/typecheck/should_run/KindInvariant.stderr b/testsuite/tests/typecheck/should_run/KindInvariant.stderr index 3fe8131daf..4f6cfffb7f 100644 --- a/testsuite/tests/typecheck/should_run/KindInvariant.stderr +++ b/testsuite/tests/typecheck/should_run/KindInvariant.stderr @@ -1,6 +1,6 @@ <interactive>:1:3: error: • Expected kind ‘* -> *’, - but ‘State#’ has kind ‘* -> TYPE 'VoidRep’ + but ‘State#’ has kind ‘* -> TYPE ('TupleRep '[])’ • In the first argument of ‘T’, namely ‘State#’ In the type ‘T State#’ diff --git a/testsuite/tests/typecheck/should_run/StrictPats.hs b/testsuite/tests/typecheck/should_run/StrictPats.hs new file mode 100644 index 0000000000..7eed9dc767 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/StrictPats.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE BangPatterns, TypeApplications, UnboxedTuples, MagicHash, + UnboxedSums, NoMonomorphismRestriction #-} +{-# OPTIONS_GHC -Wno-unused-binds -Wno-unbanged-strict-patterns #-} + +module Main where + +import Control.Exception +import GHC.Exts + +-- This stress-tests the semantics of strict patterns. + +ok :: a -> IO () +ok x = do + evaluate x + putStrLn "Evaluation successful." + +bad :: a -> IO () +bad x = do + r <- try @SomeException $ evaluate x + case r of + Left _ -> putStrLn "Exception thrown as expected." + Right _ -> putStrLn "Exception not thrown when expected." + +-- OK +a = True + where x :: Num a => a + !x = undefined -- x is a function. Should be OK. + +-- should fail +b = True + where x :: a + !x = undefined + +-- OK +c = True + where I# _ = undefined + +-- bad +d = True + where I# _x = undefined + +-- OK +e = True + where _ = undefined :: Int# + +-- bad +f = True + where _x = undefined :: Int# + +-- OK +g = True + where (# _ #) = undefined + +-- OK +h = True + where (# _x #) = undefined + +-- bad +i = True + where (# _x #) = undefined :: (# Int# #) + +-- bad +j = True + where !True = False + +-- OK +k = True + where True = False + +-- OK +l = True + where 3# = 4# + +-- bad +m = True + where !3# = 4# + +-- bad +n = True + where _x = undefined :: (# () #) + +-- OK +o = True + where (# _x #) = undefined :: (# () #) + +-- OK +p = True + where (# _ | #) = (# | True #) + +-- bad +q = True + where (# _x | #) = (# | True #) :: (# Int# | Bool #) + +-- OK +r = True + where (# _x | #) = (# | True #) + +-- bad +s = True + where !(# x #) = undefined + +main :: IO () +main = do + ok a + bad b + ok c + bad d + ok e + bad f + ok g + ok h + bad i + bad j + ok k + ok l + bad m + bad n + ok o + ok p + bad q + ok r + bad s diff --git a/testsuite/tests/typecheck/should_run/StrictPats.stdout b/testsuite/tests/typecheck/should_run/StrictPats.stdout new file mode 100644 index 0000000000..509df4e246 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/StrictPats.stdout @@ -0,0 +1,19 @@ +Evaluation successful. +Exception thrown as expected. +Evaluation successful. +Exception thrown as expected. +Evaluation successful. +Exception thrown as expected. +Evaluation successful. +Evaluation successful. +Exception thrown as expected. +Exception thrown as expected. +Evaluation successful. +Evaluation successful. +Exception thrown as expected. +Exception thrown as expected. +Evaluation successful. +Evaluation successful. +Exception thrown as expected. +Evaluation successful. +Exception thrown as expected. diff --git a/testsuite/tests/typecheck/should_run/T12809.hs b/testsuite/tests/typecheck/should_run/T12809.hs new file mode 100644 index 0000000000..9f6da26d76 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T12809.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE TypeInType, ExplicitForAll, MagicHash, UnboxedTuples, + TypeFamilies, GADTs #-} + +module Main where + +import GHC.Exts + +idint :: forall (a :: TYPE IntRep). a -> a +idint x = x + +five _ = idint 3# +# idint 2# + +type family F a where + F Int = (# Bool, Int# #) + F Char = (# Double, Int# #) + +data G a where + GInt :: G Int + GChar :: G Char + +f :: G a -> F a +f GInt = (# True, 3# #) +f GChar = (# 3.14, 5# #) + +f' :: G a -> F a +f' GInt = (# False, 7# #) +f' GChar = (# 2.71829, 11# #) + +g :: (# Bool, Int# #) -> String +g (# b, x #) = show b ++ " " ++ show (I# x) + +h :: (# Double, Int# #) -> String +h (# d, x #) = show d ++ " " ++ show (I# x) + +cond :: forall (a :: TYPE (TupleRep [LiftedRep, IntRep])). Bool -> a -> a -> a +cond True x _ = x +cond False _ x = x + +main :: IO () +main = do + print (I# (five ())) + putStrLn (g (f GInt)) + putStrLn (g (cond False (f GInt) (f' GInt))) + putStrLn (h (cond True (f GChar) (f' GChar))) diff --git a/testsuite/tests/typecheck/should_run/T12809.stdout b/testsuite/tests/typecheck/should_run/T12809.stdout new file mode 100644 index 0000000000..5d187d8652 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T12809.stdout @@ -0,0 +1,4 @@ +5 +True 3 +False 7 +3.14 5 diff --git a/testsuite/tests/typecheck/should_run/TypeOf.hs b/testsuite/tests/typecheck/should_run/TypeOf.hs index 53e035923f..59ea6fdf0d 100644 --- a/testsuite/tests/typecheck/should_run/TypeOf.hs +++ b/testsuite/tests/typecheck/should_run/TypeOf.hs @@ -27,9 +27,9 @@ main = do print $ typeOf (Proxy :: Proxy [1,2,3]) print $ typeOf (Proxy :: Proxy 'EQ) print $ typeOf (Proxy :: Proxy TYPE) - print $ typeOf (Proxy :: Proxy (TYPE 'PtrRepLifted)) + print $ typeOf (Proxy :: Proxy (TYPE 'LiftedRep)) print $ typeOf (Proxy :: Proxy *) print $ typeOf (Proxy :: Proxy ★) - print $ typeOf (Proxy :: Proxy 'PtrRepLifted) + print $ typeOf (Proxy :: Proxy 'LiftedRep) print $ typeOf (Proxy :: Proxy '(1, "hello")) print $ typeOf (Proxy :: Proxy (~~)) diff --git a/testsuite/tests/typecheck/should_run/TypeOf.stdout b/testsuite/tests/typecheck/should_run/TypeOf.stdout index 3e3396fa7e..99f113cf00 100644 --- a/testsuite/tests/typecheck/should_run/TypeOf.stdout +++ b/testsuite/tests/typecheck/should_run/TypeOf.stdout @@ -19,6 +19,6 @@ Proxy (RuntimeRep -> Constraint) TYPE Proxy Constraint Constraint Proxy Constraint Constraint Proxy Constraint Constraint -Proxy RuntimeRep 'PtrRepLifted +Proxy RuntimeRep 'LiftedRep Proxy (Nat,Symbol) ('(,) Nat Symbol 1 "hello") Proxy (Constraint -> Constraint -> Constraint) ~~ diff --git a/testsuite/tests/typecheck/should_run/TypeRep.hs b/testsuite/tests/typecheck/should_run/TypeRep.hs index 3ae9577088..5fbf909193 100644 --- a/testsuite/tests/typecheck/should_run/TypeRep.hs +++ b/testsuite/tests/typecheck/should_run/TypeRep.hs @@ -39,10 +39,10 @@ main = do print $ rep @(Proxy [1,2,3]) print $ rep @(Proxy 'EQ) print $ rep @(Proxy TYPE) - print $ rep @(Proxy (TYPE 'PtrRepLifted)) + print $ rep @(Proxy (TYPE 'LiftedRep)) print $ rep @(Proxy *) print $ rep @(Proxy ★) - print $ rep @(Proxy 'PtrRepLifted) + print $ rep @(Proxy 'LiftedRep) -- Something lifted and primitive print $ rep @RealWorld diff --git a/testsuite/tests/typecheck/should_run/TypeRep.stdout b/testsuite/tests/typecheck/should_run/TypeRep.stdout index de008640f4..09b4cea574 100644 --- a/testsuite/tests/typecheck/should_run/TypeRep.stdout +++ b/testsuite/tests/typecheck/should_run/TypeRep.stdout @@ -20,5 +20,5 @@ Proxy (RuntimeRep -> Constraint) TYPE Proxy Constraint Constraint Proxy Constraint Constraint Proxy Constraint Constraint -Proxy RuntimeRep 'PtrRepLifted +Proxy RuntimeRep 'LiftedRep RealWorld diff --git a/testsuite/tests/typecheck/should_run/all.T b/testsuite/tests/typecheck/should_run/all.T index fa6273a06d..ac63f98508 100755 --- a/testsuite/tests/typecheck/should_run/all.T +++ b/testsuite/tests/typecheck/should_run/all.T @@ -117,3 +117,6 @@ test('TypeOf', normal, compile_and_run, ['']) test('TypeRep', normal, compile_and_run, ['']) test('T11120', normal, compile_and_run, ['']) test('KindInvariant', normal, ghci_script, ['KindInvariant.script']) +test('StrictPats', normal, compile_and_run, ['']) +test('T12809', normal, compile_and_run, ['']) +test('EtaExpandLevPoly', normal, compile_and_run, ['']) diff --git a/testsuite/tests/unboxedsums/T12711.stdout b/testsuite/tests/unboxedsums/T12711.stdout index 13070dfe77..7a623a3bd6 100644 --- a/testsuite/tests/unboxedsums/T12711.stdout +++ b/testsuite/tests/unboxedsums/T12711.stdout @@ -1 +1,2 @@ -(# _ | _ #) :: TYPE 'GHC.Types.UnboxedSumRep +(# _ | _ #) :: TYPE + ('GHC.Types.SumRep '['GHC.Types.LiftedRep, 'GHC.Types.LiftedRep]) diff --git a/testsuite/tests/unboxedsums/UbxSumLevPoly.hs b/testsuite/tests/unboxedsums/UbxSumLevPoly.hs new file mode 100644 index 0000000000..3275eb7dfe --- /dev/null +++ b/testsuite/tests/unboxedsums/UbxSumLevPoly.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE UnboxedSums #-} + +module UbxSumLevPoly where + +-- this failed thinking that (# Any | True #) :: TYPE (SumRep [LiftedRep, b]) +-- But of course that b should be Lifted! + +-- It was due to silliness in TysWiredIn using the same uniques for different +-- things in mk_sum. + +p = True + where (# _x | #) = (# | True #) diff --git a/testsuite/tests/unboxedsums/all.T b/testsuite/tests/unboxedsums/all.T index 290ae43263..eea818b6f1 100644 --- a/testsuite/tests/unboxedsums/all.T +++ b/testsuite/tests/unboxedsums/all.T @@ -21,7 +21,7 @@ test('ffi1', normal, compile_fail, ['']) test('thunk', only_ways(['normal']), compile_and_run, ['']) test('T12375', only_ways(['normal']), compile_and_run, ['']) test('empty_sum', only_ways(['normal']), compile_and_run, ['']) -test('sum_rr', normal, compile_fail, ['']) +test('sum_rr', normal, compile, ['']) test('T12711', only_ways(['ghci']), ghci_script, ['T12711.script']) # TODO: Need to run this in --slow mode only @@ -30,3 +30,5 @@ test('T12711', only_ways(['ghci']), ghci_script, ['T12711.script']) # extra_files([ "unboxedsums" + str(i) + ".hs" for i in range(1, 12) ])], # run_command, # ['$MAKE -s --no-print-directory sum_api_annots']) + +test('UbxSumLevPoly', normal, compile, ['']) diff --git a/testsuite/tests/unboxedsums/sum_rr.hs b/testsuite/tests/unboxedsums/sum_rr.hs index 287edcf452..5f799fe481 100644 --- a/testsuite/tests/unboxedsums/sum_rr.hs +++ b/testsuite/tests/unboxedsums/sum_rr.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE DataKinds, KindSignatures #-} +{-# LANGUAGE TypeInType #-} module Example where import Data.Typeable import GHC.Exts -data Wat (a :: TYPE 'UnboxedSumRep) = Wat a +data Wat (a :: TYPE (SumRep '[LiftedRep, IntRep])) = Wat a diff --git a/testsuite/tests/unboxedsums/sum_rr.stderr b/testsuite/tests/unboxedsums/sum_rr.stderr deleted file mode 100644 index 2ac9b7452f..0000000000 --- a/testsuite/tests/unboxedsums/sum_rr.stderr +++ /dev/null @@ -1,7 +0,0 @@ - -sum_rr.hs:8:39: error: - • The type ‘a’ is not an unboxed sum, - and yet its kind suggests that it has the representation - of an unboxed sum. This is not allowed. - • In the definition of data constructor ‘Wat’ - In the data type declaration for ‘Wat’ diff --git a/testsuite/tests/unboxedsums/unboxedsums_unit_tests.hs b/testsuite/tests/unboxedsums/unboxedsums_unit_tests.hs index 399e074991..0b6384b6ba 100644 --- a/testsuite/tests/unboxedsums/unboxedsums_unit_tests.hs +++ b/testsuite/tests/unboxedsums/unboxedsums_unit_tests.hs @@ -46,7 +46,7 @@ layout_tests = sequence_ where assert_layout tn tys layout = let - layout_ret = ubxSumRepType tys + layout_ret = ubxSumRepType (map typePrimRep tys) in assert (layout_ret == layout) tn diff --git a/utils/haddock b/utils/haddock -Subproject b19ea3ababeb231157c4a067c43003e09b1f018 +Subproject 4349092ef61ca7da7c7cbcd9aa7dcbb97fe59bd |