diff options
| author | Richard Eisenberg <rae@cs.brynmawr.edu> | 2016-12-14 21:37:43 -0500 |
|---|---|---|
| committer | Richard Eisenberg <rae@cs.brynmawr.edu> | 2017-01-19 10:31:52 -0500 |
| commit | e7985ed23ddc68b6a2e4af753578dc1d9e8ab4c9 (patch) | |
| tree | ba8c4016e218710f8165db92d4b4c10e5559245a | |
| parent | 38374caa9d6e1373d1b9d335d0f99f3664931fd9 (diff) | |
| download | haskell-e7985ed23ddc68b6a2e4af753578dc1d9e8ab4c9.tar.gz | |
Update levity polymorphism
This commit implements the proposal in
https://github.com/ghc-proposals/ghc-proposals/pull/29 and
https://github.com/ghc-proposals/ghc-proposals/pull/35.
Here are some of the pieces of that proposal:
* Some of RuntimeRep's constructors have been shortened.
* TupleRep and SumRep are now parameterized over a list of RuntimeReps.
* This
means that two types with the same kind surely have the same
representation.
Previously, all unboxed tuples had the same kind, and thus the fact
above was
false.
* RepType.typePrimRep and friends now return a *list* of PrimReps. These
functions can now work successfully on unboxed tuples. This change is
necessary because we allow abstraction over unboxed tuple types and so
cannot
always handle unboxed tuples specially as we did before.
* We sometimes have to create an Id from a PrimRep. I thus split PtrRep
* into
LiftedRep and UnliftedRep, so that the created Ids have the right
strictness.
* The RepType.RepType type was removed, as it didn't seem to help with
* much.
* The RepType.repType function is also removed, in favor of typePrimRep.
* I have waffled a good deal on whether or not to keep VoidRep in
TyCon.PrimRep. In the end, I decided to keep it there. PrimRep is *not*
represented in RuntimeRep, and typePrimRep will never return a list
including
VoidRep. But it's handy to have in, e.g., ByteCodeGen and friends. I can
imagine another design choice where we have a PrimRepV type that is
PrimRep
with an extra constructor. That seemed to be a heavier design, though,
and I'm
not sure what the benefit would be.
* The last, unused vestiges of # (unliftedTypeKind) have been removed.
* There were several pretty-printing bugs that this change exposed;
* these are fixed.
* We previously checked for levity polymorphism in the types of binders.
* But we
also must exclude levity polymorphism in function arguments. This is
hard to check
for, requiring a good deal of care in the desugarer. See Note [Levity
polymorphism
checking] in DsMonad.
* In order to efficiently check for levity polymorphism in functions, it
* was necessary
to add a new bit of IdInfo. See Note [Levity info] in IdInfo.
* It is now safe for unlifted types to be unsaturated in Core. Core Lint
* is updated
accordingly.
* We can only know strictness after zonking, so several checks around
* strictness
in the type-checker (checkStrictBinds, the check for unlifted variables
under a ~
pattern) have been moved to the desugarer.
* Along the way, I improved the treatment of unlifted vs. banged
* bindings. See
Note [Strict binds checks] in DsBinds and #13075.
* Now that we print type-checked source, we must be careful to print
* ConLikes correctly.
This is facilitated by a new HsConLikeOut constructor to HsExpr.
Particularly troublesome
are unlifted pattern synonyms that get an extra void# argument.
* Includes a submodule update for haddock, getting rid of #.
* New testcases:
typecheck/should_fail/StrictBinds
typecheck/should_fail/T12973
typecheck/should_run/StrictPats
typecheck/should_run/T12809
typecheck/should_fail/T13105
patsyn/should_fail/UnliftedPSBind
typecheck/should_fail/LevPolyBounded
typecheck/should_compile/T12987
typecheck/should_compile/T11736
* Fixed tickets:
#12809
#12973
#11736
#13075
#12987
* This also adds a test case for #13105. This test case is
* "compile_fail" and
succeeds, because I want the testsuite to monitor the error message.
When #13105 is fixed, the test case will compile cleanly.
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 |