From d8c64e86361f6766ebe26a262bb229fb8301a42a Mon Sep 17 00:00:00 2001 From: Richard Eisenberg Date: Thu, 4 Feb 2016 10:42:56 -0500 Subject: Address #11471 by putting RuntimeRep in kinds. See Note [TYPE] in TysPrim. There are still some outstanding pieces in #11471 though, so this doesn't actually nail the bug. This commit also contains a few performance improvements: * Short-cut equality checking of nullary type syns * Compare types before kinds in eqType * INLINE coreViewOneStarKind * Store tycon binders separately from kinds. This resulted in a ~10% performance improvement in compiling the Cabal package. No change in functionality other than performance. (This affects the interface file format, though.) This commit updates the haddock submodule. --- compiler/basicTypes/DataCon.hs | 22 +- compiler/basicTypes/MkId.hs | 29 +- compiler/basicTypes/PatSyn.hs | 4 +- compiler/coreSyn/CoreLint.hs | 4 +- compiler/coreSyn/CorePrep.hs | 2 +- compiler/coreSyn/MkCore.hs | 20 +- compiler/deSugar/DsBinds.hs | 2 +- compiler/deSugar/DsForeign.hs | 8 +- compiler/deSugar/DsUtils.hs | 4 +- compiler/ghci/RtClosureInspect.hs | 4 +- compiler/iface/BinIface.hs | 2 +- compiler/iface/BuildTyCl.hs | 9 +- compiler/iface/IfaceEnv.hs | 2 +- compiler/iface/IfaceSyn.hs | 148 +++++----- compiler/iface/IfaceType.hs | 119 ++++++-- compiler/iface/MkIface.hs | 35 +-- compiler/iface/TcIface.hs | 96 +++--- compiler/prelude/PrelNames.hs | 38 ++- compiler/prelude/PrimOp.hs | 2 +- compiler/prelude/TysPrim.hs | 192 +++++++----- compiler/prelude/TysWiredIn.hs | 267 +++++++++++++---- compiler/prelude/TysWiredIn.hs-boot | 22 +- compiler/typecheck/Inst.hs | 127 +++++++- compiler/typecheck/TcBinds.hs | 2 +- compiler/typecheck/TcCanonical.hs | 4 +- compiler/typecheck/TcDeriv.hs | 2 +- compiler/typecheck/TcErrors.hs | 26 +- compiler/typecheck/TcExpr.hs | 12 +- compiler/typecheck/TcHsSyn.hs | 26 +- compiler/typecheck/TcHsType.hs | 325 +++++++-------------- compiler/typecheck/TcInstDcls.hs | 7 +- compiler/typecheck/TcInteract.hs | 2 +- compiler/typecheck/TcMType.hs | 34 ++- compiler/typecheck/TcPat.hs | 4 +- compiler/typecheck/TcPatSyn.hs | 18 +- compiler/typecheck/TcRnDriver.hs | 2 +- compiler/typecheck/TcSMonad.hs | 6 +- compiler/typecheck/TcSimplify.hs | 22 +- compiler/typecheck/TcSplice.hs | 36 +-- compiler/typecheck/TcTyClsDecls.hs | 196 +++++++------ compiler/typecheck/TcType.hs | 12 +- compiler/typecheck/TcTypeNats.hs | 12 +- compiler/typecheck/TcUnify.hs | 19 +- compiler/typecheck/TcValidity.hs | 4 +- compiler/types/Kind.hs | 30 +- compiler/types/TyCoRep.hs | 92 +++--- compiler/types/TyCoRep.hs-boot | 2 + compiler/types/TyCon.hs | 302 ++++++++++++------- compiler/types/Type.hs | 133 +++++---- compiler/utils/Util.hs | 16 + compiler/vectorise/Vectorise/Exp.hs | 2 +- compiler/vectorise/Vectorise/Generic/PData.hs | 3 +- compiler/vectorise/Vectorise/Type/Env.hs | 2 +- compiler/vectorise/Vectorise/Type/TyConDecl.hs | 5 +- libraries/base/Data/Data.hs | 2 +- libraries/base/Data/Typeable/Internal.hs | 28 +- libraries/base/GHC/Err.hs | 8 +- libraries/base/GHC/Exts.hs | 4 +- libraries/base/tests/T11334.hs | 4 +- libraries/ghc-prim/GHC/Types.hs | 73 ++++- testsuite/tests/dependent/should_compile/T11405.hs | 2 +- .../dependent/should_fail/BadTelescope4.stderr | 6 +- .../tests/dependent/should_fail/TypeSkolEscape.hs | 2 +- .../dependent/should_fail/TypeSkolEscape.stderr | 10 +- testsuite/tests/ghci/scripts/T4175.stdout | 10 +- testsuite/tests/ghci/scripts/T7627.stdout | 8 +- testsuite/tests/ghci/scripts/T7939.stdout | 19 +- testsuite/tests/ghci/scripts/T8535.stdout | 2 +- testsuite/tests/ghci/scripts/T9181.stdout | 18 +- testsuite/tests/ghci/scripts/ghci020.stdout | 2 +- testsuite/tests/ghci/should_run/T10145.stdout | 2 +- .../indexed-types/should_compile/T3017.stderr | 4 +- .../indexed-types/should_fail/ClosedFam3.stderr | 45 ++- .../indexed-types/should_fail/Overlap4.stderr | 9 +- .../indexed-types/should_fail/SimpleFail1a.stderr | 3 +- .../indexed-types/should_fail/TyFamArity1.stderr | 8 +- .../indexed-types/should_fail/TyFamArity2.stderr | 13 +- .../tests/indexed-types/should_run/T11465a.hs | 2 +- .../tests/partial-sigs/should_compile/ADT.stderr | 1 - .../should_compile/DataFamilyInstanceLHS.stderr | 1 - .../partial-sigs/should_compile/Meltdown.stderr | 3 +- .../NamedWildcardInDataFamilyInstanceLHS.stderr | 1 - .../NamedWildcardInTypeFamilyInstanceLHS.stderr | 3 +- .../partial-sigs/should_compile/SkipMany.stderr | 1 - .../should_compile/TypeFamilyInstanceLHS.stderr | 3 +- testsuite/tests/perf/compiler/all.T | 3 +- testsuite/tests/polykinds/T11399.stderr | 4 +- testsuite/tests/polykinds/T7328.stderr | 2 +- testsuite/tests/polykinds/TidyClassKinds.stderr | 2 +- testsuite/tests/roles/should_compile/Roles1.stderr | 7 - testsuite/tests/roles/should_compile/Roles2.stderr | 2 - testsuite/tests/roles/should_compile/Roles3.stderr | 6 +- testsuite/tests/roles/should_compile/T8958.stderr | 1 - .../tests/simplCore/should_compile/T9400.stderr | 2 +- .../simplCore/should_compile/spec-inline.stderr | 2 +- testsuite/tests/th/TH_Roles2.stderr | 5 +- .../tests/typecheck/should_compile/tc231.stderr | 2 - .../typecheck/should_run/KindInvariant.stderr | 3 +- testsuite/tests/typecheck/should_run/TypeOf.hs | 4 +- testsuite/tests/typecheck/should_run/TypeOf.stdout | 4 +- utils/genprimopcode/Main.hs | 114 ++++---- utils/haddock | 2 +- 102 files changed, 1756 insertions(+), 1222 deletions(-) diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs index 8552205483..57a9857cd4 100644 --- a/compiler/basicTypes/DataCon.hs +++ b/compiler/basicTypes/DataCon.hs @@ -720,6 +720,7 @@ mkDataCon :: Name -> ThetaType -- ^ Theta-type occuring before the arguments proper -> [Type] -- ^ Original argument types -> Type -- ^ Original result type + -> RuntimeRepInfo -- ^ See comments on 'TyCon.RuntimeRepInfo' -> TyCon -- ^ Representation type constructor -> ThetaType -- ^ The "stupid theta", context of the data -- declaration e.g. @data Eq a => T a ...@ @@ -733,7 +734,7 @@ mkDataCon name declared_infix prom_info fields univ_tvs ex_tvs eq_spec theta - orig_arg_tys orig_res_ty rep_tycon + orig_arg_tys orig_res_ty rep_info rep_tycon stupid_theta work_id rep -- Warning: mkDataCon is not a good place to check invariants. -- If the programmer writes the wrong result type in the decl, thus: @@ -774,8 +775,15 @@ mkDataCon name declared_infix prom_info mkFunTys rep_arg_tys $ mkTyConApp rep_tycon (mkTyVarTys univ_tvs) - promoted -- See Note [Promoted data constructors] in TyCon - = mkPromotedDataCon con name prom_info (dataConUserType con) roles + -- See Note [Promoted data constructors] in TyCon + prom_binders = map (mkNamedBinder Specified) + ((univ_tvs `minusList` map eqSpecTyVar eq_spec) ++ + ex_tvs) ++ + map mkAnonBinder theta ++ + map mkAnonBinder orig_arg_tys + prom_res_kind = orig_res_ty + promoted + = mkPromotedDataCon con name prom_info prom_binders prom_res_kind roles rep_info roles = map (const Nominal) (univ_tvs ++ ex_tvs) ++ map (const Representational) orig_arg_tys @@ -1106,9 +1114,7 @@ isVanillaDataCon dc = dcVanilla dc -- | Should this DataCon be allowed in a type even without -XDataKinds? -- Currently, only Lifted & Unlifted specialPromotedDc :: DataCon -> Bool -specialPromotedDc dc - = dc `hasKey` liftedDataConKey || - dc `hasKey` unliftedDataConKey +specialPromotedDc = isKindTyCon . dataConTyCon -- | Was this datacon promotable before GHC 8.0? That is, is it promotable -- without -XTypeInType @@ -1228,7 +1234,7 @@ buildAlgTyCon :: Name buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs is_rec gadt_syn parent - = mkAlgTyCon tc_name kind ktvs roles cType stupid_theta + = mkAlgTyCon tc_name binders liftedTypeKind ktvs roles cType stupid_theta rhs parent is_rec gadt_syn where - kind = mkPiTypesPreferFunTy ktvs liftedTypeKind + binders = mkTyBindersPreferAnon ktvs liftedTypeKind diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs index a64e922e21..8ee5013a96 100644 --- a/compiler/basicTypes/MkId.hs +++ b/compiler/basicTypes/MkId.hs @@ -1062,11 +1062,11 @@ dollarId = pcMiscPrelId dollarName ty (noCafIdInfo `setUnfoldingInfo` unf) where fun_ty = mkFunTy alphaTy openBetaTy - ty = mkSpecForAllTys [levity2TyVar, alphaTyVar, openBetaTyVar] $ + ty = mkSpecForAllTys [runtimeRep2TyVar, alphaTyVar, openBetaTyVar] $ mkFunTy fun_ty fun_ty unf = mkInlineUnfolding (Just 2) rhs [f,x] = mkTemplateLocals [fun_ty, alphaTy] - rhs = mkLams [levity2TyVar, alphaTyVar, openBetaTyVar, f, x] $ + rhs = mkLams [runtimeRep2TyVar, alphaTyVar, openBetaTyVar, f, x] $ App (Var f) (Var x) ------------------------------------------------ @@ -1083,7 +1083,9 @@ proxyHashId t = mkTyVarTy tv ------------------------------------------------ --- unsafeCoerce# :: forall a b. a -> b +-- unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) +-- (a :: TYPE r1) (b :: TYPE r2). +-- a -> b unsafeCoerceId :: Id unsafeCoerceId = pcMiscPrelId unsafeCoerceName ty info @@ -1091,14 +1093,13 @@ unsafeCoerceId info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` mkCompulsoryUnfolding rhs - ty = mkSpecForAllTys [ levity1TyVar, levity2TyVar - , openAlphaTyVar, openBetaTyVar ] - (mkFunTy openAlphaTy openBetaTy) + tvs = [ runtimeRep1TyVar, runtimeRep2TyVar + , openAlphaTyVar, openBetaTyVar ] + + ty = mkSpecForAllTys tvs $ mkFunTy openAlphaTy openBetaTy [x] = mkTemplateLocals [openAlphaTy] - rhs = mkLams [ levity1TyVar, levity2TyVar - , openAlphaTyVar, openBetaTyVar - , x] $ + rhs = mkLams (tvs ++ [x]) $ Cast (Var x) (mkUnsafeCo Representational openAlphaTy openBetaTy) ------------------------------------------------ @@ -1166,13 +1167,13 @@ oneShotId = pcMiscPrelId oneShotName ty info where info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` mkCompulsoryUnfolding rhs - ty = mkSpecForAllTys [ levity1TyVar, levity2TyVar + ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar , openAlphaTyVar, openBetaTyVar ] (mkFunTy fun_ty fun_ty) - fun_ty = mkFunTy alphaTy betaTy + fun_ty = mkFunTy openAlphaTy openBetaTy [body, x] = mkTemplateLocals [fun_ty, openAlphaTy] x' = setOneShotLambda x - rhs = mkLams [ levity1TyVar, levity2TyVar + rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar , openAlphaTyVar, openBetaTyVar , body, x'] $ Var body `App` Var x @@ -1196,7 +1197,7 @@ runRWId = pcMiscPrelId runRWName ty info arg_ty = stateRW `mkFunTy` ret_ty -- (State# RealWorld -> (# State# RealWorld, o #)) -- -> (# State# RealWorld, o #) - ty = mkSpecForAllTys [levity1TyVar, openAlphaTyVar] $ + ty = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] $ arg_ty `mkFunTy` ret_ty -------------------------------------------------------------------------------- @@ -1375,7 +1376,7 @@ no further floating will occur. This allows us to safely inline things like While the definition of @GHC.Magic.runRW#@, we override its type in @MkId@ to be open-kinded, - runRW# :: forall (lev :: Levity). (o :: TYPE lev) + runRW# :: forall (r1 :: RuntimeRep). (o :: TYPE r) => (State# RealWorld -> (# State# RealWorld, o #)) -> (# State# RealWorld, o #) diff --git a/compiler/basicTypes/PatSyn.hs b/compiler/basicTypes/PatSyn.hs index 65826583dd..cef94767a9 100644 --- a/compiler/basicTypes/PatSyn.hs +++ b/compiler/basicTypes/PatSyn.hs @@ -79,7 +79,7 @@ data PatSyn -- Matcher function. -- If Bool is True then prov_theta and arg_tys are empty -- and type is - -- forall (v :: Levity) (r :: TYPE v) univ_tvs. + -- forall (p :: RuntimeRep) (r :: TYPE p) univ_tvs. -- req_theta -- => res_ty -- -> (forall ex_tvs. Void# -> r) @@ -87,7 +87,7 @@ data PatSyn -- -> r -- -- Otherwise type is - -- forall (v :: Levity) (r :: TYPE v) univ_tvs. + -- forall (p :: RuntimeRep) (r :: TYPE r) univ_tvs. -- req_theta -- => res_ty -- -> (forall ex_tvs. prov_theta => arg_tys -> r) diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index 6dbcbe4ce9..f9cb4be3b3 100644 --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -988,8 +988,8 @@ lintAndScopeId id linterF (text "Non-local Id binder" <+> ppr id) -- See Note [Checking for global Ids] ; (ty, k) <- lintInTy (idType id) - ; lintL (not (isLevityPolymorphic k)) - (text "Levity polymorphic binder:" <+> + ; lintL (not (isRuntimeRepPolymorphic k)) + (text "RuntimeRep-polymorphic binder:" <+> (ppr id <+> dcolon <+> parens (ppr ty <+> dcolon <+> ppr k))) ; let id' = setIdType id ty ; addInScopeVar id' $ (linterF id') } diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs index 4708df3f48..3f9f4c8470 100644 --- a/compiler/coreSyn/CorePrep.hs +++ b/compiler/coreSyn/CorePrep.hs @@ -512,7 +512,7 @@ cpeRhsE env (Var f `App` _{-type-} `App` arg) | f `hasKey` lazyIdKey -- Replace (lazy a) by a = cpeRhsE env arg -- See Note [lazyId magic] in MkId -cpeRhsE env (Var f `App` _levity `App` _type `App` arg) +cpeRhsE env (Var f `App` _runtimeRep `App` _type `App` arg) -- See Note [runRW magic] in MkId | f `hasKey` runRWKey -- Replace (runRW# f) by (f realWorld#), = case arg of -- beta reducing if possible diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs index 94a264c120..0eccccc2e4 100644 --- a/compiler/coreSyn/MkCore.hs +++ b/compiler/coreSyn/MkCore.hs @@ -322,13 +322,13 @@ mkCoreTup cs = mkCoreConApps (tupleDataCon Boxed (length cs)) -- | Build a small unboxed tuple holding the specified expressions, -- with the given types. The types must be the types of the expressions. --- Do not include the levity specifiers; this function calculates them +-- Do not include the RuntimeRep specifiers; this function calculates them -- for you. mkCoreUbxTup :: [Type] -> [CoreExpr] -> CoreExpr mkCoreUbxTup tys exps = ASSERT( tys `equalLength` exps) mkCoreConApps (tupleDataCon Unboxed (length tys)) - (map (Type . getLevity "mkCoreUbxTup") tys ++ map Type tys ++ exps) + (map (Type . getRuntimeRep "mkCoreUbxTup") tys ++ map Type tys ++ exps) -- | Make a core tuple of the given boxity mkCoreTupBoxity :: Boxity -> [CoreExpr] -> CoreExpr @@ -588,7 +588,8 @@ mkRuntimeErrorApp -> CoreExpr mkRuntimeErrorApp err_id res_ty err_msg - = mkApps (Var err_id) [Type (getLevity "mkRuntimeErrorApp" res_ty), Type res_ty, err_string] + = mkApps (Var err_id) [ Type (getRuntimeRep "mkRuntimeErrorApp" res_ty) + , Type res_ty, err_string ] where err_string = Lit (mkMachString err_msg) @@ -672,21 +673,18 @@ mkRuntimeErrorId name = pc_bottoming_Id1 name runtimeErrorTy runtimeErrorTy :: Type -- The runtime error Ids take a UTF8-encoded string as argument -runtimeErrorTy = mkSpecSigmaTy [levity1TyVar, openAlphaTyVar] [] +runtimeErrorTy = mkSpecSigmaTy [runtimeRep1TyVar, openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy) {- Note [Error and friends have an "open-tyvar" forall] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 'error' and 'undefined' have types - error :: forall (v :: Levity) (a :: TYPE v). String -> a - undefined :: forall (v :: Levity) (a :: TYPE v). a -Notice the levity polymophism. This ensures that -"error" can be instantiated at - * unboxed as well as boxed types - * polymorphic types + error :: forall (v :: RuntimeRep) (a :: TYPE v). String -> a + undefined :: forall (v :: RuntimeRep) (a :: TYPE v). a +Notice the runtime-representation polymophism. 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. -See Note [Sort-polymorphic tyvars accept foralls] in TcMType. ************************************************************************ diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index 4f05d07942..420090db36 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -1067,7 +1067,7 @@ dsEvTerm (EvDelayedError ty msg) = return $ dsEvDelayedError ty msg dsEvDelayedError :: Type -> FastString -> CoreExpr dsEvDelayedError ty msg - = Var errorId `mkTyApps` [getLevity "dsEvTerm" ty, ty] `mkApps` [litMsg] + = Var errorId `mkTyApps` [getRuntimeRep "dsEvTerm" ty, ty] `mkApps` [litMsg] where errorId = tYPE_ERROR_ID litMsg = Lit (MachStr (fastStringToByteString msg)) diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs index a87526ff6c..26c84c764d 100644 --- a/compiler/deSugar/DsForeign.hs +++ b/compiler/deSugar/DsForeign.hs @@ -198,7 +198,10 @@ dsFCall fn_id co fcall mDeclHeader = do ty = pFst $ coercionKind co (all_bndrs, io_res_ty) = tcSplitPiTys ty (named_bndrs, arg_tys) = partitionBindersIntoBinders all_bndrs - tvs = map (binderVar "dsFCall") named_bndrs + tvs = ASSERT( fst (span isNamedBinder all_bndrs) + `equalLength` named_bndrs ) + -- ensure that the named binders all come first + map (binderVar "dsFCall") named_bndrs -- Must use tcSplit* functions because we want to -- see that (IO t) in the corner @@ -302,6 +305,7 @@ dsPrimCall fn_id co fcall = do -- Must use tcSplit* functions because we want to -- see that (IO t) in the corner + MASSERT( fst (span isNamedBinder bndrs) `equalLength` tvs ) args <- newSysLocalsDs arg_tys ccall_uniq <- newUnique @@ -412,6 +416,8 @@ dsFExportDynamic :: Id -> CCallConv -> DsM ([Binding], SDoc, SDoc) dsFExportDynamic id co0 cconv = do + MASSERT( fst (span isNamedBinder bndrs) `equalLength` tvs ) + -- make sure that the named binders all come first fe_id <- newSysLocalDs ty mod <- getModule dflags <- getDynFlags diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs index 0ddfb97529..ece50d877a 100644 --- a/compiler/deSugar/DsUtils.hs +++ b/compiler/deSugar/DsUtils.hs @@ -343,7 +343,7 @@ sort_alts = sortWith (dataConTag . alt_pat) mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr mkPatSynCase var ty alt fail = do matcher <- dsLExpr $ mkLHsWrap wrapper $ - nlHsTyApp matcher [getLevity "mkPatSynCase" ty, ty] + nlHsTyApp matcher [getRuntimeRep "mkPatSynCase" ty, ty] let MatchResult _ mkCont = match_result cont <- mkCoreLams bndrs <$> mkCont fail return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail] @@ -469,7 +469,7 @@ mkErrorAppDs err_id ty msg = do full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg]) core_msg = Lit (mkMachString full_msg) -- mkMachString returns a result of type String# - return (mkApps (Var err_id) [Type (getLevity "mkErrorAppDs" ty), Type ty, core_msg]) + return (mkApps (Var err_id) [Type (getRuntimeRep "mkErrorAppDs" ty), Type ty, core_msg]) {- 'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'. diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index 1832ea4819..a76a298172 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -800,8 +800,8 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 (nonPtrs clos) go ptr_i ws (ty:tys) | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty , isUnboxedTupleTyCon tc - -- See Note [Unboxed tuple levity vars] in TyCon - = do (ptr_i, ws, terms0) <- go ptr_i ws (dropLevityArgs elem_tys) + -- See Note [Unboxed tuple RuntimeRep vars] in TyCon + = do (ptr_i, ws, terms0) <- go ptr_i ws (dropRuntimeRepArgs elem_tys) (ptr_i, ws, terms1) <- go ptr_i ws tys return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1) | otherwise diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index c0926fc22e..a7246afc03 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -344,7 +344,7 @@ putTupleName_ bh tc tup_sort thing_tag (sort_tag, arity) = case tup_sort of BoxedTuple -> (0, fromIntegral (tyConArity tc)) UnboxedTuple -> (1, fromIntegral (tyConArity tc `div` 2)) - -- See Note [Unboxed tuple levity vars] in TyCon + -- See Note [Unboxed tuple RuntimeRep vars] in TyCon ConstraintTuple -> pprPanic "putTupleName:ConstraintTuple" (ppr tc) -- See Note [Symbol table representation of names] diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs index 0022e29f11..87b5f36b7e 100644 --- a/compiler/iface/BuildTyCl.hs +++ b/compiler/iface/BuildTyCl.hs @@ -138,7 +138,7 @@ buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs fie data_con = mkDataCon src_name declared_infix prom_info src_bangs field_lbls univ_tvs ex_tvs eq_spec ctxt - arg_tys res_ty rep_tycon + arg_tys res_ty NoRRI rep_tycon stupid_ctxt dc_wrk dc_rep dc_wrk = mkDataConWorkId work_name data_con dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name @@ -215,7 +215,7 @@ type TcMethInfo = (Name, Type, Maybe (DefMethSpec Type)) buildClass :: Name -- Name of the class/tycon (they have the same Name) -> [TyVar] -> [Role] -> ThetaType - -> Kind + -> [TyBinder] -> [FunDep TyVar] -- Functional dependencies -> [ClassATItem] -- Associated types -> [TcMethInfo] -- Method info @@ -223,7 +223,8 @@ buildClass :: Name -- Name of the class/tycon (they have the same Name) -> RecFlag -- Info for type constructor -> TcRnIf m n Class -buildClass tycon_name tvs roles sc_theta kind fds at_items sig_stuff mindef tc_isrec +buildClass tycon_name tvs roles sc_theta binders + fds at_items sig_stuff mindef tc_isrec = fixM $ \ rec_clas -> -- Only name generation inside loop do { traceIf (text "buildClass") @@ -286,7 +287,7 @@ buildClass tycon_name tvs roles sc_theta kind fds at_items sig_stuff mindef tc_i , tup_sort = ConstraintTuple }) else return (mkDataTyConRhs [dict_con]) - ; let { tycon = mkClassTyCon tycon_name kind tvs roles + ; let { tycon = mkClassTyCon tycon_name binders tvs roles rhs rec_clas tc_isrec tc_rep_name -- A class can be recursive, and in the case of newtypes -- this matters. For example diff --git a/compiler/iface/IfaceEnv.hs b/compiler/iface/IfaceEnv.hs index 43094f94aa..20b497bee3 100644 --- a/compiler/iface/IfaceEnv.hs +++ b/compiler/iface/IfaceEnv.hs @@ -49,7 +49,7 @@ import Data.List ( partition ) Note [The Name Cache] ~~~~~~~~~~~~~~~~~~~~~ -The Name Cache makes sure that, during any invovcation of GHC, each +The Name Cache makes sure that, during any invocation of GHC, each External Name "M.x" has one, and only one globally-agreed Unique. * The first time we come across M.x we make up a Unique and record that diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs index 7b6b34c728..91132851a8 100644 --- a/compiler/iface/IfaceSyn.hs +++ b/compiler/iface/IfaceSyn.hs @@ -95,9 +95,9 @@ data IfaceDecl ifIdInfo :: IfaceIdInfo } | IfaceData { ifName :: IfaceTopBndr, -- Type constructor - ifKind :: IfaceType, -- Kind of type constructor + ifBinders :: [IfaceTyConBinder], + ifResKind :: IfaceType, -- Result kind of type constructor ifCType :: Maybe CType, -- C type for CAPI FFI - ifTyVars :: [IfaceTvBndr], -- Type variables ifRoles :: [Role], -- Roles ifCtxt :: IfaceContext, -- The "stupid theta" ifCons :: IfaceConDecls, -- Includes new/data/data family info @@ -109,25 +109,24 @@ data IfaceDecl } | IfaceSynonym { ifName :: IfaceTopBndr, -- Type constructor - ifTyVars :: [IfaceTvBndr], -- Type variables ifRoles :: [Role], -- Roles - ifSynKind :: IfaceKind, -- Kind of the *tycon* + ifBinders :: [IfaceTyConBinder], + ifResKind :: IfaceKind, -- Kind of the *result* ifSynRhs :: IfaceType } | IfaceFamily { ifName :: IfaceTopBndr, -- Type constructor - ifTyVars :: [IfaceTvBndr], -- Type variables ifResVar :: Maybe IfLclName, -- Result variable name, used -- only for pretty-printing -- with --show-iface - ifFamKind :: IfaceKind, -- Kind of the *tycon* + ifBinders :: [IfaceTyConBinder], + ifResKind :: IfaceKind, -- Kind of the *tycon* ifFamFlav :: IfaceFamTyConFlav, ifFamInj :: Injectivity } -- injectivity information | IfaceClass { ifCtxt :: IfaceContext, -- Superclasses ifName :: IfaceTopBndr, -- Name of the class TyCon - ifTyVars :: [IfaceTvBndr], -- Type variables ifRoles :: [Role], -- Roles - ifKind :: IfaceType, -- Kind of TyCon + ifBinders :: [IfaceTyConBinder], ifFDs :: [FunDep FastString], -- Functional dependencies ifATs :: [IfaceAT], -- Associated type families ifSigs :: [IfaceClassOp], -- Method signatures @@ -619,11 +618,11 @@ pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc -- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi -- See Note [Pretty-printing TyThings] in PprTyThing pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype, - ifCtxt = context, ifTyVars = tc_tyvars, + ifCtxt = context, ifRoles = roles, ifCons = condecls, ifParent = parent, ifRec = isrec, ifGadtSyntax = gadt, - ifKind = kind }) + ifBinders = binders }) | gadt_style = vcat [ pp_roles , pp_nd <+> pp_lhs <+> pp_where @@ -641,14 +640,14 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype, pp_cons = ppr_trim (map show_con cons) :: [SDoc] pp_lhs = case parent of - IfNoParent -> pprIfaceDeclHead context ss tycon kind tc_tyvars + IfNoParent -> pprIfaceDeclHead context ss tycon binders Nothing _ -> text "instance" <+> pprIfaceTyConParent parent pp_roles | is_data_instance = empty | otherwise = pprRoles (== Representational) (pprPrefixIfDeclBndr ss tycon) - tc_bndrs roles + binders roles -- Don't display roles for data family instances (yet) -- See discussion on Trac #8672. @@ -658,50 +657,29 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype, ok_con dc = showSub ss dc || any (showSub ss) (ifConFields dc) show_con dc - | ok_con dc = Just $ pprIfaceConDecl ss gadt_style mk_user_con_res_ty fls dc + | ok_con dc = Just $ pprIfaceConDecl ss gadt_style fls tycon binders parent dc | otherwise = Nothing fls = ifaceConDeclFields condecls - mk_user_con_res_ty :: IfaceEqSpec -> ([IfaceTvBndr], SDoc) - -- See Note [Result type of a data family GADT] - mk_user_con_res_ty eq_spec - | IfDataInstance _ tc tys <- parent - = (con_univ_tvs, pprIfaceType (IfaceTyConApp tc (substIfaceTcArgs gadt_subst tys))) - | otherwise - = (con_univ_tvs, sdocWithDynFlags (ppr_tc_app gadt_subst)) - where - gadt_subst = mkFsEnv eq_spec - done_univ_tv (tv,_) = isJust (lookupFsEnv gadt_subst tv) - con_univ_tvs = filterOut done_univ_tv tc_tyvars - - ppr_tc_app gadt_subst dflags - = pprPrefixIfDeclBndr ss tycon - <+> sep [ pprParendIfaceType (substIfaceTyVar gadt_subst tv) - | (tv,_kind) - <- suppressIfaceInvisibles dflags tc_bndrs tc_tyvars ] - (tc_bndrs, _, _) = splitIfaceSigmaTy kind - pp_nd = case condecls of IfAbstractTyCon d -> text "abstract" <> ppShowIface ss (parens (ppr d)) IfDataTyCon{} -> text "data" IfNewTyCon{} -> text "newtype" - pp_extra = vcat [pprCType ctype, pprRec isrec, text "Kind:" <+> ppr kind] + pp_extra = vcat [pprCType ctype, pprRec isrec] pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec , ifCtxt = context, ifName = clas - , ifTyVars = tyvars, ifRoles = roles + , ifRoles = roles , ifFDs = fds, ifMinDef = minDef - , ifKind = kind }) - = vcat [ pprRoles (== Nominal) (pprPrefixIfDeclBndr ss clas) bndrs roles - , text "class" <+> pprIfaceDeclHead context ss clas kind tyvars + , ifBinders = binders }) + = vcat [ pprRoles (== Nominal) (pprPrefixIfDeclBndr ss clas) binders roles + , text "class" <+> pprIfaceDeclHead context ss clas binders Nothing <+> pprFundeps fds <+> pp_where , nest 2 (vcat [ vcat asocs, vcat dsigs, pprec , ppShowAllSubs ss (pprMinDef minDef)])] where - (bndrs, _, _) = splitIfaceSigmaTy kind - pp_where = ppShowRhs ss $ ppUnless (null sigs && null ats) (text "where") asocs = ppr_trim $ map maybeShowAssoc ats @@ -726,26 +704,27 @@ pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec text "#-}" pprIfaceDecl ss (IfaceSynonym { ifName = tc - , ifTyVars = tv + , ifBinders = binders , ifSynRhs = mono_ty - , ifSynKind = kind}) - = hang (text "type" <+> pprIfaceDeclHead [] ss tc kind tv <+> equals) - 2 (sep [pprIfaceForAll tvs, pprIfaceContextArr theta, ppr tau]) + , ifResKind = res_kind}) + = hang (text "type" <+> pprIfaceDeclHead [] ss tc binders Nothing <+> equals) + 2 (sep [ pprIfaceForAll tvs, pprIfaceContextArr theta, ppr tau + , ppUnless (isIfaceLiftedTypeKind res_kind) (dcolon <+> ppr res_kind) ]) where (tvs, theta, tau) = splitIfaceSigmaTy mono_ty -pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars - , ifFamFlav = rhs, ifFamKind = kind +pprIfaceDecl ss (IfaceFamily { ifName = tycon + , ifFamFlav = rhs, ifBinders = binders + , ifResKind = res_kind , ifResVar = res_var, ifFamInj = inj }) | IfaceDataFamilyTyCon <- rhs - = text "data family" <+> pprIfaceDeclHead [] ss tycon kind tyvars + = text "data family" <+> pprIfaceDeclHead [] ss tycon binders Nothing | otherwise - = hang (text "type family" <+> pprIfaceDeclHead [] ss tycon kind tyvars) + = hang (text "type family" <+> pprIfaceDeclHead [] ss tycon binders (Just res_kind)) 2 (pp_inj res_var inj <+> ppShowRhs ss (pp_rhs rhs)) $$ - nest 2 ( vcat [ text "Kind:" <+> ppr kind - , ppShowRhs ss (pp_branches rhs) ] ) + nest 2 (ppShowRhs ss (pp_branches rhs)) where pp_inj Nothing _ = empty pp_inj (Just res) inj @@ -753,9 +732,9 @@ pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars , pp_inj_cond res injectivity] | otherwise = hsep [ equals, ppr res ] - pp_inj_cond res inj = case filterByList inj tyvars of + pp_inj_cond res inj = case filterByList inj binders of [] -> empty - tvs -> hsep [vbar, ppr res, text "->", interppSP (map fst tvs)] + tvs -> hsep [vbar, ppr res, text "->", interppSP (map ifTyConBinderName tvs)] pp_rhs IfaceDataFamilyTyCon = ppShowIface ss (text "data") @@ -808,7 +787,7 @@ pprCType (Just cType) = text "C type:" <+> ppr cType -- if, for each role, suppress_if role is True, then suppress the role -- output -pprRoles :: (Role -> Bool) -> SDoc -> [IfaceForAllBndr] +pprRoles :: (Role -> Bool) -> SDoc -> [IfaceTyConBinder] -> [Role] -> SDoc pprRoles suppress_if tyCon bndrs roles = sdocWithDynFlags $ \dflags -> @@ -862,15 +841,15 @@ pprIfaceTyConParent (IfDataInstance _ tc tys) in pprIfaceTypeApp tc ftys pprIfaceDeclHead :: IfaceContext -> ShowSub -> OccName - -> IfaceType -- of the tycon, for invisible-suppression - -> [IfaceTvBndr] -> SDoc -pprIfaceDeclHead context ss tc_occ kind tyvars + -> [IfaceTyConBinder] -- of the tycon, for invisible-suppression + -> Maybe IfaceKind + -> SDoc +pprIfaceDeclHead context ss tc_occ bndrs m_res_kind = sdocWithDynFlags $ \ dflags -> sep [ pprIfaceContextArr context , pprPrefixIfDeclBndr ss tc_occ - <+> pprIfaceTvBndrs (suppressIfaceInvisibles dflags bndrs tyvars) ] - where - (bndrs, _, _) = splitIfaceSigmaTy kind + <+> pprIfaceTyConBinders (suppressIfaceInvisibles dflags bndrs bndrs) + , maybe empty (\res_kind -> dcolon <+> pprIfaceType res_kind) m_res_kind ] isVanillaIfaceConDecl :: IfaceConDecl -> Bool isVanillaIfaceConDecl (IfCon { ifConExTvs = ex_tvs @@ -879,10 +858,12 @@ isVanillaIfaceConDecl (IfCon { ifConExTvs = ex_tvs = (null ex_tvs) && (null eq_spec) && (null ctxt) pprIfaceConDecl :: ShowSub -> Bool - -> (IfaceEqSpec -> ([IfaceTvBndr], SDoc)) -> [FieldLbl OccName] + -> IfaceTopBndr + -> [IfaceTyConBinder] + -> IfaceTyConParent -> IfaceConDecl -> SDoc -pprIfaceConDecl ss gadt_style mk_user_con_res_ty fls +pprIfaceConDecl ss gadt_style fls tycon tc_binders parent (IfCon { ifConOcc = name, ifConInfix = is_infix, ifConExTvs = ex_tvs, ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys, @@ -935,6 +916,25 @@ pprIfaceConDecl ss gadt_style mk_user_con_res_ty fls -- DuplicateRecordFields was used for the definition) lbl = maybe sel (mkVarOccFS . flLabel) $ find (\ fl -> flSelector fl == sel) fls + mk_user_con_res_ty :: IfaceEqSpec -> ([IfaceTvBndr], SDoc) + -- See Note [Result type of a data family GADT] + mk_user_con_res_ty eq_spec + | IfDataInstance _ tc tys <- parent + = (con_univ_tvs, pprIfaceType (IfaceTyConApp tc (substIfaceTcArgs gadt_subst tys))) + | otherwise + = (con_univ_tvs, sdocWithDynFlags (ppr_tc_app gadt_subst)) + where + gadt_subst = mkFsEnv eq_spec + done_univ_tv (tv,_) = isJust (lookupFsEnv gadt_subst tv) + con_univ_tvs = filterOut done_univ_tv (map ifTyConBinderTyVar tc_binders) + + ppr_tc_app gadt_subst dflags + = pprPrefixIfDeclBndr ss tycon + <+> sep [ pprParendIfaceType (substIfaceTyVar gadt_subst tv) + | (tv,_kind) + <- map ifTyConBinderTyVar $ + suppressIfaceInvisibles dflags tc_binders tc_binders ] + instance Outputable IfaceRule where ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs }) @@ -1149,23 +1149,22 @@ freeNamesIfDecl (IfaceId _s t d i) = freeNamesIfIdInfo i &&& freeNamesIfIdDetails d freeNamesIfDecl d@IfaceData{} = - freeNamesIfType (ifKind d) &&& - freeNamesIfTvBndrs (ifTyVars d) &&& + freeNamesIfTyBinders (ifBinders d) &&& + freeNamesIfType (ifResKind d) &&& freeNamesIfaceTyConParent (ifParent d) &&& freeNamesIfContext (ifCtxt d) &&& freeNamesIfConDecls (ifCons d) freeNamesIfDecl d@IfaceSynonym{} = - freeNamesIfTvBndrs (ifTyVars d) &&& freeNamesIfType (ifSynRhs d) &&& - freeNamesIfKind (ifSynKind d) + freeNamesIfTyBinders (ifBinders d) &&& + freeNamesIfKind (ifResKind d) freeNamesIfDecl d@IfaceFamily{} = - freeNamesIfTvBndrs (ifTyVars d) &&& freeNamesIfFamFlav (ifFamFlav d) &&& - freeNamesIfKind (ifFamKind d) + freeNamesIfTyBinders (ifBinders d) &&& + freeNamesIfKind (ifResKind d) freeNamesIfDecl d@IfaceClass{} = - freeNamesIfTvBndrs (ifTyVars d) &&& freeNamesIfContext (ifCtxt d) &&& - freeNamesIfType (ifKind d) &&& + freeNamesIfTyBinders (ifBinders d) &&& fnList freeNamesIfAT (ifATs d) &&& fnList freeNamesIfClsSig (ifSigs d) freeNamesIfDecl d@IfaceAxiom{} = @@ -1305,6 +1304,13 @@ freeNamesIfTvBndrs = fnList freeNamesIfTvBndr freeNamesIfForAllBndr :: IfaceForAllBndr -> NameSet freeNamesIfForAllBndr (IfaceTv tv _) = freeNamesIfTvBndr tv +freeNamesIfTyBinder :: IfaceTyConBinder -> NameSet +freeNamesIfTyBinder (IfaceAnon _ ty) = freeNamesIfType ty +freeNamesIfTyBinder (IfaceNamed b) = freeNamesIfForAllBndr b + +freeNamesIfTyBinders :: [IfaceTyConBinder] -> NameSet +freeNamesIfTyBinders = fnList freeNamesIfTyBinder + freeNamesIfBndr :: IfaceBndr -> NameSet freeNamesIfBndr (IfaceIdBndr b) = freeNamesIfIdBndr b freeNamesIfBndr (IfaceTvBndr b) = freeNamesIfTvBndr b @@ -1475,7 +1481,7 @@ instance Binary IfaceDecl where put_ bh a5 put_ bh a6 - put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do + put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7 a8 a9) = do putByte bh 5 put_ bh a1 put_ bh (occNameFS a2) @@ -1486,7 +1492,6 @@ instance Binary IfaceDecl where put_ bh a7 put_ bh a8 put_ bh a9 - put_ bh a10 put_ bh (IfaceAxiom a1 a2 a3 a4) = do putByte bh 6 @@ -1555,9 +1560,8 @@ instance Binary IfaceDecl where a7 <- get bh a8 <- get bh a9 <- get bh - a10 <- get bh occ <- return $! mkClsOccFS a2 - return (IfaceClass a1 occ a3 a4 a5 a6 a7 a8 a9 a10) + return (IfaceClass a1 occ a3 a4 a5 a6 a7 a8 a9) 6 -> do a1 <- get bh a2 <- get bh a3 <- get bh diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs index ee7e4308d8..52454ffb5e 100644 --- a/compiler/iface/IfaceType.hs +++ b/compiler/iface/IfaceType.hs @@ -17,18 +17,21 @@ module IfaceType ( IfaceTyCon(..), IfaceTyConInfo(..), IfaceTyLit(..), IfaceTcArgs(..), IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr, - IfaceTvBndr, IfaceIdBndr, + IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder(..), IfaceForAllBndr(..), VisibilityFlag(..), + ifConstraintKind, ifTyConBinderTyVar, ifTyConBinderName, + -- Equality testing IfRnEnv2, emptyIfRnEnv2, eqIfaceType, eqIfaceTypes, - eqIfaceTcArgs, eqIfaceTvBndrs, + eqIfaceTcArgs, eqIfaceTvBndrs, isIfaceLiftedTypeKind, -- Conversion from Type -> IfaceType toIfaceType, toIfaceTypes, toIfaceKind, toIfaceTyVar, toIfaceContext, toIfaceBndr, toIfaceIdBndr, toIfaceTyCon, toIfaceTyCon_name, toIfaceTcArgs, toIfaceTvBndrs, + zipIfaceBinders, toDegenerateBinders, -- Conversion from IfaceTcArgs -> IfaceType tcArgsIfaceTypes, @@ -39,7 +42,7 @@ module IfaceType ( -- Printing pprIfaceType, pprParendIfaceType, pprIfaceContext, pprIfaceContextArr, pprIfaceContextMaybe, - pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTvBndrs, + pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTyConBinders, pprIfaceBndrs, pprIfaceTcArgs, pprParendIfaceTcArgs, pprIfaceForAllPart, pprIfaceForAll, pprIfaceSigmaType, pprIfaceCoercion, pprParendIfaceCoercion, @@ -59,7 +62,6 @@ import DataCon ( isTupleDataCon ) import TcType import DynFlags import TyCoRep -- needs to convert core types to iface types -import Unique( hasKey ) import TyCon hiding ( pprPromotionQuote ) import CoAxiom import Id @@ -67,7 +69,7 @@ import Var -- import RnEnv( FastStringEnv, mkFsEnv, lookupFsEnv ) import TysWiredIn import TysPrim -import PrelNames( funTyConKey, ipClassKey ) +import PrelNames import Name import BasicTypes import Binary @@ -145,6 +147,11 @@ data IfaceTyLit data IfaceForAllBndr = IfaceTv IfaceTvBndr VisibilityFlag +data IfaceTyConBinder + = IfaceAnon IfLclName IfaceType -- like Anon, but it includes a name from + -- which to produce a tyConTyVar + | IfaceNamed IfaceForAllBndr + -- See Note [Suppressing invisible arguments] -- We use a new list type (rather than [(IfaceType,Bool)], because -- it'll be more compact and faster to parse in interface @@ -194,6 +201,12 @@ data IfaceUnivCoProv | IfaceProofIrrelProv IfaceCoercion | IfacePluginProv String +-- this constant is needed for dealing with pretty-printing classes +ifConstraintKind :: IfaceKind +ifConstraintKind = IfaceTyConApp (IfaceTyCon { ifaceTyConName = getName constraintKindTyCon + , ifaceTyConInfo = NoIfaceTyConInfo }) + ITC_Nil + {- %************************************************************************ %* * @@ -205,6 +218,15 @@ data IfaceUnivCoProv eqIfaceTvBndr :: IfaceTvBndr -> IfaceTvBndr -> Bool eqIfaceTvBndr (occ1, _) (occ2, _) = occ1 == occ2 +isIfaceLiftedTypeKind :: IfaceKind -> Bool +isIfaceLiftedTypeKind (IfaceTyConApp tc ITC_Nil) + = isLiftedTypeKindTyConName (ifaceTyConName tc) +isIfaceLiftedTypeKind (IfaceTyConApp tc + (ITC_Vis (IfaceTyConApp ptr_rep_lifted ITC_Nil) ITC_Nil)) + = ifaceTyConName tc == tYPETyConName + && ifaceTyConName ptr_rep_lifted `hasKey` ptrRepLiftedDataConKey +isIfaceLiftedTypeKind _ = False + splitIfaceSigmaTy :: IfaceType -> ([IfaceForAllBndr], [IfacePredType], IfaceType) -- Mainly for printing purposes splitIfaceSigmaTy ty @@ -221,7 +243,7 @@ splitIfaceSigmaTy ty = case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) } split_rho tau = ([], tau) -suppressIfaceInvisibles :: DynFlags -> [IfaceForAllBndr] -> [a] -> [a] +suppressIfaceInvisibles :: DynFlags -> [IfaceTyConBinder] -> [a] -> [a] suppressIfaceInvisibles dflags tys xs | gopt Opt_PrintExplicitKinds dflags = xs | otherwise = suppress tys xs @@ -232,14 +254,25 @@ suppressIfaceInvisibles dflags tys xs | isIfaceInvisBndr k = suppress ks xs | otherwise = a -stripIfaceInvisVars :: DynFlags -> [IfaceForAllBndr] -> [IfaceForAllBndr] +stripIfaceInvisVars :: DynFlags -> [IfaceTyConBinder] -> [IfaceTyConBinder] stripIfaceInvisVars dflags tyvars | gopt Opt_PrintExplicitKinds dflags = tyvars | otherwise = filterOut isIfaceInvisBndr tyvars -isIfaceInvisBndr :: IfaceForAllBndr -> Bool -isIfaceInvisBndr (IfaceTv _ Visible) = False -isIfaceInvisBndr _ = True +isIfaceInvisBndr :: IfaceTyConBinder -> Bool +isIfaceInvisBndr (IfaceNamed (IfaceTv _ Invisible)) = True +isIfaceInvisBndr (IfaceNamed (IfaceTv _ Specified)) = True +isIfaceInvisBndr _ = False + +-- | Extract a IfaceTvBndr from a IfaceTyConBinder +ifTyConBinderTyVar :: IfaceTyConBinder -> IfaceTvBndr +ifTyConBinderTyVar (IfaceAnon name ki) = (name, ki) +ifTyConBinderTyVar (IfaceNamed (IfaceTv tv _)) = tv + +-- | Extract the variable name from a IfaceTyConBinder +ifTyConBinderName :: IfaceTyConBinder -> IfLclName +ifTyConBinderName (IfaceAnon name _) = name +ifTyConBinderName (IfaceNamed (IfaceTv (name, _) _)) = name ifTyVarsOfType :: IfaceType -> UniqSet IfLclName ifTyVarsOfType ty @@ -568,16 +601,15 @@ pprIfaceIdBndr :: (IfLclName, IfaceType) -> SDoc pprIfaceIdBndr (name, ty) = parens (ppr name <+> dcolon <+> ppr ty) pprIfaceTvBndr :: IfaceTvBndr -> SDoc -pprIfaceTvBndr (tv, IfaceTyConApp tc ITC_Nil) - | isLiftedTypeKindTyConName (ifaceTyConName tc) = ppr tv -pprIfaceTvBndr (tv, IfaceTyConApp tc (ITC_Vis (IfaceTyConApp lifted ITC_Nil) ITC_Nil)) - | ifaceTyConName tc == tYPETyConName - , ifaceTyConName lifted == liftedDataConName - = ppr tv -pprIfaceTvBndr (tv, kind) = parens (ppr tv <+> dcolon <+> ppr kind) +pprIfaceTvBndr (tv, ki) + | isIfaceLiftedTypeKind ki = ppr tv + | otherwise = parens (ppr tv <+> dcolon <+> ppr ki) -pprIfaceTvBndrs :: [IfaceTvBndr] -> SDoc -pprIfaceTvBndrs tyvars = sep (map pprIfaceTvBndr tyvars) +pprIfaceTyConBinders :: [IfaceTyConBinder] -> SDoc +pprIfaceTyConBinders = sep . map go + where + go (IfaceAnon name ki) = pprIfaceTvBndr (name, ki) + go (IfaceNamed (IfaceTv tv _)) = pprIfaceTvBndr tv instance Binary IfaceBndr where put_ bh (IfaceIdBndr aa) = do @@ -786,11 +818,14 @@ pprTyTcApp ctxt_prec tc tys dflags = pprIfaceTyList ctxt_prec ty1 ty2 | ifaceTyConName tc == tYPETyConName - , ITC_Vis (IfaceTyConApp lev_tc ITC_Nil) ITC_Nil <- tys - = let n = ifaceTyConName lev_tc in - if n == liftedDataConName then char '*' - else if n == unliftedDataConName then char '#' - else pprPanic "IfaceType.pprTyTcApp" (ppr lev_tc) + , ITC_Vis (IfaceTyConApp ptr_rep ITC_Nil) ITC_Nil <- tys + , ifaceTyConName ptr_rep `hasKey` ptrRepLiftedDataConKey + = char '*' + + | ifaceTyConName tc == tYPETyConName + , ITC_Vis (IfaceTyConApp ptr_rep ITC_Nil) ITC_Nil <- tys + , ifaceTyConName ptr_rep `hasKey` ptrRepUnliftedDataConKey + = char '#' | otherwise = ppr_iface_tc_app ppr_ty ctxt_prec tc tys_wo_kinds @@ -826,8 +861,8 @@ ppr_iface_tc_app pp ctxt_prec tc tys pprTuple :: TupleSort -> IfaceTyConInfo -> IfaceTcArgs -> SDoc pprTuple sort info args - = -- drop the levity vars. - -- See Note [Unboxed tuple levity vars] in TyCon + = -- drop the RuntimeRep vars. + -- See Note [Unboxed tuple RuntimeRep vars] in TyCon let tys = tcArgsIfaceTypes args args' = case sort of UnboxedTuple -> drop (length tys `div` 2) tys @@ -968,6 +1003,21 @@ instance Binary IfaceForAllBndr where vis <- get bh return (IfaceTv tv vis) +instance Binary IfaceTyConBinder where + put_ bh (IfaceAnon n ty) = putByte bh 0 >> put_ bh n >> put_ bh ty + put_ bh (IfaceNamed b) = putByte bh 1 >> put_ bh b + + get bh = + do c <- getByte bh + case c of + 0 -> do + n <- get bh + ty <- get bh + return $! IfaceAnon n ty + _ -> do + b <- get bh + return $! IfaceNamed b + instance Binary IfaceTcArgs where put_ bh tk = case tk of @@ -1360,3 +1410,20 @@ toIfaceUnivCoProv (PhantomProv co) = IfacePhantomProv (toIfaceCoercion co) toIfaceUnivCoProv (ProofIrrelProv co) = IfaceProofIrrelProv (toIfaceCoercion co) toIfaceUnivCoProv (PluginProv str) = IfacePluginProv str toIfaceUnivCoProv (HoleProv h) = pprPanic "toIfaceUnivCoProv hit a hole" (ppr h) + +---------------------- +-- | Zip together tidied tyConTyVars with tyConBinders to make IfaceTyConBinders +zipIfaceBinders :: [TyVar] -> [TyBinder] -> [IfaceTyConBinder] +zipIfaceBinders = zipWith go + where + go tv (Anon _) = let (name, ki) = toIfaceTvBndr tv in + IfaceAnon name ki + go tv (Named _ vis) = IfaceNamed (IfaceTv (toIfaceTvBndr tv) vis) + +-- | Make IfaceTyConBinders without tyConTyVars. Used for pretty-printing only +toDegenerateBinders :: [TyBinder] -> [IfaceTyConBinder] +toDegenerateBinders = zipWith go [1..] + where + go :: Int -> TyBinder -> IfaceTyConBinder + go n (Anon ty) = IfaceAnon (mkFastString ("t" ++ show n)) (toIfaceType ty) + go _ (Named tv vis) = IfaceNamed (IfaceTv (toIfaceTvBndr tv) vis) diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index 8548eb3031..4bd5c3611f 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -76,7 +76,6 @@ import DataCon import PatSyn import Type import TcType -import TysPrim ( alphaTyVars ) import InstEnv import FamInstEnv import TcRnMonad @@ -1377,28 +1376,28 @@ tyConToIfaceDecl env tycon | Just syn_rhs <- synTyConRhs_maybe tycon = ( tc_env1 , IfaceSynonym { ifName = getOccName tycon, - ifTyVars = if_tc_tyvars, ifRoles = tyConRoles tycon, ifSynRhs = if_syn_type syn_rhs, - ifSynKind = if_kind + ifBinders = if_binders, + ifResKind = if_res_kind }) | Just fam_flav <- famTyConFlav_maybe tycon = ( tc_env1 , IfaceFamily { ifName = getOccName tycon, - ifTyVars = if_tc_tyvars, ifResVar = if_res_var, ifFamFlav = to_if_fam_flav fam_flav, - ifFamKind = if_kind, + ifBinders = if_binders, + ifResKind = if_res_kind, ifFamInj = familyTyConInjectivityInfo tycon }) | isAlgTyCon tycon = ( tc_env1 , IfaceData { ifName = getOccName tycon, - ifKind = if_kind, + ifBinders = if_binders, + ifResKind = if_res_kind, ifCType = tyConCType tycon, - ifTyVars = if_tc_tyvars, ifRoles = tyConRoles tycon, ifCtxt = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon), ifCons = ifaceConDecls (algTyConRhs tycon) (algTcFields tycon), @@ -1410,12 +1409,10 @@ tyConToIfaceDecl env tycon -- For pretty printing purposes only. = ( env , IfaceData { ifName = getOccName tycon, - ifKind = - -- These don't have `tyConTyVars`, so we use an empty - -- environment here, instead of `tc_env1` defined below. - tidyToIfaceType emptyTidyEnv (tyConKind tycon), + ifBinders = if_degenerate_binders, + ifResKind = if_degenerate_res_kind, + -- These don't have `tyConTyVars`, hence "degenerate" ifCType = Nothing, - ifTyVars = funAndPrimTyVars, ifRoles = tyConRoles tycon, ifCtxt = [], ifCons = IfDataTyCon [] False [], @@ -1427,12 +1424,16 @@ tyConToIfaceDecl env tycon -- is one of these TyCons (FunTyCon, PrimTyCon, PromotedDataCon) will cause -- an error. (tc_env1, tc_tyvars) = tidyTyClTyCoVarBndrs env (tyConTyVars tycon) - if_tc_tyvars = toIfaceTvBndrs tc_tyvars - if_kind = tidyToIfaceType tc_env1 (tyConKind tycon) + if_binders = zipIfaceBinders tc_tyvars (tyConBinders tycon) + if_res_kind = tidyToIfaceType tc_env1 (tyConResKind tycon) if_syn_type ty = tidyToIfaceType tc_env1 ty if_res_var = getFS `fmap` tyConFamilyResVar_maybe tycon - funAndPrimTyVars = toIfaceTvBndrs $ take (tyConArity tycon) alphaTyVars + -- use these when you don't have tyConTyVars + (degenerate_binders, degenerate_res_kind) + = splitPiTys (tidyType env (tyConKind tycon)) + if_degenerate_binders = toDegenerateBinders degenerate_binders + if_degenerate_res_kind = toIfaceType degenerate_res_kind parent = case tyConFamInstSig_maybe tycon of Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax) @@ -1522,9 +1523,8 @@ classToIfaceDecl env clas = ( env1 , IfaceClass { ifCtxt = tidyToIfaceContext env1 sc_theta, ifName = getOccName tycon, - ifTyVars = toIfaceTvBndrs clas_tyvars', ifRoles = tyConRoles (classTyCon clas), - ifKind = tidyToIfaceType env1 (tyConKind tycon), + ifBinders = binders, ifFDs = map toIfaceFD clas_fds, ifATs = map toIfaceAT clas_ats, ifSigs = map toIfaceClassOp op_stuff, @@ -1536,6 +1536,7 @@ classToIfaceDecl env clas tycon = classTyCon clas (env1, clas_tyvars') = tidyTyCoVarBndrs env clas_tyvars + binders = zipIfaceBinders clas_tyvars' (tyConBinders tycon) toIfaceAT :: ClassATItem -> IfaceAT toIfaceAT (ATI tc def) diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs index 2e8a6ed796..8599afabec 100644 --- a/compiler/iface/TcIface.hs +++ b/compiler/iface/TcIface.hs @@ -312,20 +312,21 @@ tc_iface_decl _ ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, tc_iface_decl _ _ (IfaceData {ifName = occ_name, ifCType = cType, - ifKind = kind, - ifTyVars = tv_bndrs, + ifBinders = binders, + ifResKind = res_kind, ifRoles = roles, ifCtxt = ctxt, ifGadtSyntax = gadt_syn, ifCons = rdr_cons, ifRec = is_rec, ifParent = mb_parent }) - = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do + = bindIfaceTyConBinders_AT binders $ \ tyvars binders' -> do { tc_name <- lookupIfaceTop occ_name - ; kind' <- tcIfaceType kind + ; res_kind' <- tcIfaceType res_kind + ; tycon <- fixM $ \ tycon -> do { stupid_theta <- tcIfaceCtxt ctxt ; parent' <- tc_parent tc_name mb_parent ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons - ; return (mkAlgTyCon tc_name kind' tyvars roles cType stupid_theta + ; return (mkAlgTyCon tc_name binders' res_kind' tyvars roles cType stupid_theta cons parent' is_rec gadt_syn) } ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) ; return (ATyCon tycon) } @@ -341,31 +342,33 @@ tc_iface_decl _ _ (IfaceData {ifName = occ_name, ; lhs_tys <- tcIfaceTcArgs arg_tys ; return (DataFamInstTyCon ax_unbr fam_tc lhs_tys) } -tc_iface_decl _ _ (IfaceSynonym {ifName = occ_name, ifTyVars = tv_bndrs, +tc_iface_decl _ _ (IfaceSynonym {ifName = occ_name, ifRoles = roles, ifSynRhs = rhs_ty, - ifSynKind = kind }) - = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do + ifBinders = binders, + ifResKind = res_kind }) + = bindIfaceTyConBinders_AT binders $ \ tyvars binders' -> do { tc_name <- lookupIfaceTop occ_name - ; kind <- tcIfaceType kind -- Note [Synonym kind loop] + ; res_kind' <- tcIfaceType res_kind -- Note [Synonym kind loop] ; rhs <- forkM (mk_doc tc_name) $ tcIfaceType rhs_ty - ; let tycon = mkSynonymTyCon tc_name kind tyvars roles rhs + ; let tycon = mkSynonymTyCon tc_name binders' res_kind' tyvars roles rhs ; return (ATyCon tycon) } where mk_doc n = text "Type synonym" <+> ppr n -tc_iface_decl parent _ (IfaceFamily {ifName = occ_name, ifTyVars = tv_bndrs, +tc_iface_decl parent _ (IfaceFamily {ifName = occ_name, ifFamFlav = fam_flav, - ifFamKind = kind, + ifBinders = binders, + ifResKind = res_kind, ifResVar = res, ifFamInj = inj }) - = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do - { tc_name <- lookupIfaceTop occ_name - ; kind <- tcIfaceType kind -- Note [Synonym kind loop] + = bindIfaceTyConBinders_AT binders $ \ tyvars binders' -> do + { tc_name <- lookupIfaceTop occ_name + ; res_kind' <- tcIfaceType res_kind -- Note [Synonym kind loop] ; rhs <- forkM (mk_doc tc_name) $ tc_fam_flav tc_name fam_flav ; res_name <- traverse (newIfaceName . mkTyVarOccFS) res - ; let tycon = mkFamilyTyCon tc_name kind tyvars res_name rhs parent inj + ; let tycon = mkFamilyTyCon tc_name binders' res_kind' tyvars res_name rhs parent inj ; return (ATyCon tycon) } where mk_doc n = text "Type synonym" <+> ppr n @@ -386,15 +389,15 @@ tc_iface_decl parent _ (IfaceFamily {ifName = occ_name, ifTyVars = tv_bndrs, tc_iface_decl _parent ignore_prags (IfaceClass {ifCtxt = rdr_ctxt, ifName = tc_occ, - ifTyVars = tv_bndrs, ifRoles = roles, ifKind = kind, + ifRoles = roles, + ifBinders = binders, ifFDs = rdr_fds, ifATs = rdr_ats, ifSigs = rdr_sigs, ifMinDef = mindef_occ, ifRec = tc_isrec }) -- ToDo: in hs-boot files we should really treat abstract classes specially, -- as we do abstract tycons - = bindIfaceTvBndrs tv_bndrs $ \ tyvars -> do + = bindIfaceTyConBinders binders $ \ tyvars binders' -> do { tc_name <- lookupIfaceTop tc_occ - ; kind' <- tcIfaceType kind ; traceIf (text "tc-iface-class1" <+> ppr tc_occ) ; ctxt <- mapM tc_sc rdr_ctxt ; traceIf (text "tc-iface-class2" <+> ppr tc_occ) @@ -405,7 +408,7 @@ tc_iface_decl _parent ignore_prags ; cls <- fixM $ \ cls -> do { ats <- mapM (tc_at cls) rdr_ats ; traceIf (text "tc-iface-class4" <+> ppr tc_occ) - ; buildClass tc_name tyvars roles ctxt kind' fds ats sigs mindef tc_isrec } + ; buildClass tc_name tyvars roles ctxt binders' fds ats sigs mindef tc_isrec } ; return (ATyCon (classTyCon cls)) } where tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred) @@ -509,7 +512,8 @@ tc_ax_branch prev_branches (IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbCoVars = cv_bndrs , ifaxbLHS = lhs, ifaxbRHS = rhs , ifaxbRoles = roles, ifaxbIncomps = incomps }) - = bindIfaceTyVars_AT tv_bndrs $ \ tvs -> + = bindIfaceTyConBinders_AT + (map (\b -> IfaceNamed (IfaceTv b Invisible)) tv_bndrs) $ \ tvs _ -> -- The _AT variant is needed here; see Note [CoAxBranch type variables] in CoAxiom bindIfaceIds cv_bndrs $ \ cvs -> do { tc_lhs <- tcIfaceTcArgs lhs @@ -905,7 +909,7 @@ tcIfaceTupleTy sort info args kind_args = map typeKind args' ; return (mkTyConApp tc (kind_args ++ args')) } } --- See Note [Unboxed tuple levity vars] in TyCon +-- See Note [Unboxed tuple RuntimeRep vars] in TyCon tcTupleTyCon :: Bool -- True <=> typechecking a *type* (vs. an expr) -> TupleSort -> Arity -- the number of args. *not* the tuple arity. @@ -1024,7 +1028,7 @@ tcIfaceExpr (IfaceTuple sort args) ; let con_tys = map exprType args' some_con_args = map Type con_tys ++ args' con_args = case sort of - UnboxedTuple -> map (Type . getLevity "tcIfaceExpr") con_tys ++ some_con_args + UnboxedTuple -> map (Type . getRuntimeRep "tcIfaceExpr") con_tys ++ some_con_args _ -> some_con_args -- Put the missing type arguments back in con_id = dataConWorkId (tyConSingleDataCon tc) @@ -1426,21 +1430,39 @@ mk_iface_tyvar name ifKind = do { kind <- tcIfaceType ifKind ; return (Var.mkTyVar name kind) } -bindIfaceTyVars_AT :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a +bindIfaceTyConBinders :: [IfaceTyConBinder] + -> ([TyVar] -> [TyBinder] -> IfL a) -> IfL a +bindIfaceTyConBinders [] thing_inside = thing_inside [] [] +bindIfaceTyConBinders (b:bs) thing_inside + = bindIfaceTyConBinderX bindIfaceTyVar b $ \ tv' b' -> + bindIfaceTyConBinders bs $ \ tvs' bs' -> + thing_inside (tv':tvs') (b':bs') + +bindIfaceTyConBinders_AT :: [IfaceTyConBinder] + -> ([TyVar] -> [TyBinder] -> IfL a) -> IfL a -- Used for type variable in nested associated data/type declarations -- where some of the type variables are already in scope -- class C a where { data T a b } -- Here 'a' is in scope when we look at the 'data T' -bindIfaceTyVars_AT [] thing_inside - = thing_inside [] -bindIfaceTyVars_AT (b : bs) thing_inside - = do { bindIfaceTyVar_AT b $ \b' -> - bindIfaceTyVars_AT bs $ \bs' -> - thing_inside (b':bs') } - -bindIfaceTyVar_AT :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a -bindIfaceTyVar_AT tv thing - = do { mb_tv <- lookupIfaceTyVar tv - ; case mb_tv of - Just b' -> thing b' - Nothing -> bindIfaceTyVar tv thing } +bindIfaceTyConBinders_AT [] thing_inside + = thing_inside [] [] +bindIfaceTyConBinders_AT (b : bs) thing_inside + = bindIfaceTyConBinderX bind_tv b $ \tv' b' -> + bindIfaceTyConBinders_AT bs $ \tvs' bs' -> + thing_inside (tv':tvs') (b':bs') + where + bind_tv tv thing + = do { mb_tv <- lookupIfaceTyVar tv + ; case mb_tv of + Just b' -> thing b' + Nothing -> bindIfaceTyVar tv thing } + +bindIfaceTyConBinderX :: (IfaceTvBndr -> (TyVar -> IfL a) -> IfL a) + -> IfaceTyConBinder + -> (TyVar -> TyBinder -> IfL a) -> IfL a +bindIfaceTyConBinderX bind_tv (IfaceAnon name ki) thing_inside + = bind_tv (name, ki) $ \ tv' -> + thing_inside tv' (Anon (tyVarKind tv')) +bindIfaceTyConBinderX bind_tv (IfaceNamed (IfaceTv tv vis)) thing_inside + = bind_tv tv $ \tv' -> + thing_inside tv' (Named tv' vis) diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs index 5c2984be2a..068f276d05 100644 --- a/compiler/prelude/PrelNames.hs +++ b/compiler/prelude/PrelNames.hs @@ -1617,15 +1617,18 @@ eitherTyConKey = mkPreludeTyConUnique 84 -- Kind constructors liftedTypeKindTyConKey, tYPETyConKey, - unliftedTypeKindTyConKey, constraintKindTyConKey, levityTyConKey, - starKindTyConKey, unicodeStarKindTyConKey :: Unique + unliftedTypeKindTyConKey, constraintKindTyConKey, + starKindTyConKey, unicodeStarKindTyConKey, runtimeRepTyConKey, + vecCountTyConKey, vecElemTyConKey :: Unique liftedTypeKindTyConKey = mkPreludeTyConUnique 87 tYPETyConKey = mkPreludeTyConUnique 88 unliftedTypeKindTyConKey = mkPreludeTyConUnique 89 -levityTyConKey = mkPreludeTyConUnique 90 constraintKindTyConKey = mkPreludeTyConUnique 92 starKindTyConKey = mkPreludeTyConUnique 93 unicodeStarKindTyConKey = mkPreludeTyConUnique 94 +runtimeRepTyConKey = mkPreludeTyConUnique 95 +vecCountTyConKey = mkPreludeTyConUnique 96 +vecElemTyConKey = mkPreludeTyConUnique 97 pluginTyConKey, frontendPluginTyConKey :: Unique pluginTyConKey = mkPreludeTyConUnique 102 @@ -1808,11 +1811,6 @@ fingerprintDataConKey = mkPreludeDataConUnique 35 srcLocDataConKey :: Unique srcLocDataConKey = mkPreludeDataConUnique 37 --- Levity -liftedDataConKey, unliftedDataConKey :: Unique -liftedDataConKey = mkPreludeDataConUnique 39 -unliftedDataConKey = mkPreludeDataConUnique 40 - trTyConTyConKey, trTyConDataConKey, trModuleTyConKey, trModuleDataConKey, trNameTyConKey, trNameSDataConKey, trNameDDataConKey, @@ -1861,6 +1859,26 @@ metaDataDataConKey = mkPreludeDataConUnique 68 metaConsDataConKey = mkPreludeDataConUnique 69 metaSelDataConKey = mkPreludeDataConUnique 70 +vecRepDataConKey :: Unique +vecRepDataConKey = mkPreludeDataConUnique 71 + +-- See Note [Wiring in RuntimeRep] in TysWiredIn +runtimeRepSimpleDataConKeys :: [Unique] +ptrRepLiftedDataConKey, ptrRepUnliftedDataConKey :: Unique +runtimeRepSimpleDataConKeys@( + ptrRepLiftedDataConKey : ptrRepUnliftedDataConKey : _) + = map mkPreludeDataConUnique [72..82] + +-- See Note [Wiring in RuntimeRep] in TysWiredIn +-- VecCount +vecCountDataConKeys :: [Unique] +vecCountDataConKeys = map mkPreludeDataConUnique [83..88] + +-- See Note [Wiring in RuntimeRep] in TysWiredIn +-- VecElem +vecElemDataConKeys :: [Unique] +vecElemDataConKeys = map mkPreludeDataConUnique [89..98] + ---------------- Template Haskell ------------------- -- THNames.hs: USES DataUniques 100-150 ----------------------------------------------------- @@ -2232,5 +2250,5 @@ pretendNameIsInScope :: Name -> Bool pretendNameIsInScope n = any (n `hasKey`) [ starKindTyConKey, liftedTypeKindTyConKey, tYPETyConKey - , unliftedTypeKindTyConKey, levityTyConKey, liftedDataConKey - , unliftedDataConKey ] + , unliftedTypeKindTyConKey + , runtimeRepTyConKey, ptrRepLiftedDataConKey, ptrRepUnliftedDataConKey ] diff --git a/compiler/prelude/PrimOp.hs b/compiler/prelude/PrimOp.hs index 66172acd24..7b37062aa4 100644 --- a/compiler/prelude/PrimOp.hs +++ b/compiler/prelude/PrimOp.hs @@ -30,7 +30,7 @@ import TysWiredIn import CmmType import Demand import OccName ( OccName, pprOccName, mkVarOccFS ) -import TyCon ( TyCon, isPrimTyCon, tyConPrimRep, PrimRep(..) ) +import TyCon ( TyCon, isPrimTyCon, PrimRep(..) ) import Type import BasicTypes ( Arity, Fixity(..), FixityDirection(..), Boxity(..) ) import ForeignCall ( CLabelString ) diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs index d1e42d5a10..ce25c308a1 100644 --- a/compiler/prelude/TysPrim.hs +++ b/compiler/prelude/TysPrim.hs @@ -15,13 +15,11 @@ module TysPrim( mkTemplateTyVars, alphaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar, alphaTys, alphaTy, betaTy, gammaTy, deltaTy, - levity1TyVar, levity2TyVar, levity1Ty, levity2Ty, + runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep1Ty, runtimeRep2Ty, openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, kKiVar, -- Kind constructors... - tYPETyCon, unliftedTypeKindTyCon, unliftedTypeKind, - tYPETyConName, unliftedTypeKindTyConName, -- Kinds @@ -80,7 +78,18 @@ module TysPrim( #include "HsVersions.h" -import {-# SOURCE #-} TysWiredIn ( levityTy, unliftedDataConTy, liftedTypeKind ) +import {-# SOURCE #-} TysWiredIn + ( runtimeRepTy, liftedTypeKind + , vecRepDataConTyCon, ptrRepUnliftedDataConTyCon + , voidRepDataConTy, intRepDataConTy + , wordRepDataConTy, int64RepDataConTy, word64RepDataConTy, addrRepDataConTy + , floatRepDataConTy, doubleRepDataConTy + , vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy + , vec64DataConTy + , int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy + , int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy + , word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy + , doubleElemRepDataConTy ) import Var ( TyVar, KindVar, mkTyVar ) import Name @@ -89,6 +98,7 @@ import SrcLoc import Unique import PrelNames import FastString +import Outputable import TyCoRep -- doesn't need special access, but this is easier to avoid -- import loops @@ -228,17 +238,17 @@ alphaTys = mkTyVarTys alphaTyVars alphaTy, betaTy, gammaTy, deltaTy :: Type (alphaTy:betaTy:gammaTy:deltaTy:_) = alphaTys -levity1TyVar, levity2TyVar :: TyVar -(levity1TyVar : levity2TyVar : _) - = drop 21 (mkTemplateTyVars (repeat levityTy)) -- selects 'v','w' +runtimeRep1TyVar, runtimeRep2TyVar :: TyVar +(runtimeRep1TyVar : runtimeRep2TyVar : _) + = drop 16 (mkTemplateTyVars (repeat runtimeRepTy)) -- selects 'q','r' -levity1Ty, levity2Ty :: Type -levity1Ty = mkTyVarTy levity1TyVar -levity2Ty = mkTyVarTy levity2TyVar +runtimeRep1Ty, runtimeRep2Ty :: Type +runtimeRep1Ty = mkTyVarTy runtimeRep1TyVar +runtimeRep2Ty = mkTyVarTy runtimeRep2TyVar openAlphaTyVar, openBetaTyVar :: TyVar [openAlphaTyVar,openBetaTyVar] - = mkTemplateTyVars [tYPE levity1Ty, tYPE levity2Ty] + = mkTemplateTyVars [tYPE runtimeRep1Ty, tYPE runtimeRep2Ty] openAlphaTy, openBetaTy :: Type openAlphaTy = mkTyVarTy openAlphaTyVar @@ -260,9 +270,9 @@ funTyConName :: Name funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon funTyCon :: TyCon -funTyCon = mkFunTyCon funTyConName kind tc_rep_nm +funTyCon = mkFunTyCon funTyConName (map Anon [liftedTypeKind, liftedTypeKind]) + tc_rep_nm where - kind = mkFunTys [liftedTypeKind, liftedTypeKind] liftedTypeKind -- You might think that (->) should have type (?? -> ? -> *), and you'd be right -- But if we do that we get kind errors when saying -- instance Control.Arrow (->) @@ -274,20 +284,6 @@ funTyCon = mkFunTyCon funTyConName kind tc_rep_nm tc_rep_nm = mkPrelTyConRepName funTyConName --- One step to remove subkinding. --- (->) :: * -> * -> * --- but we should have (and want) the following typing rule for fully applied arrows --- Gamma |- tau :: k1 k1 in {*, #} --- Gamma |- sigma :: k2 k2 in {*, #, (#)} --- ----------------------------------------- --- Gamma |- tau -> sigma :: * --- Currently we have the following rule which achieves more or less the same effect --- Gamma |- tau :: ?? --- Gamma |- sigma :: ? --- -------------------------- --- Gamma |- tau -> sigma :: * --- In the end we don't want subkinding at all. - {- ************************************************************************ * * @@ -299,35 +295,48 @@ Note [TYPE] ~~~~~~~~~~~ There are a few places where we wish to be able to deal interchangeably with kind * and kind #. unsafeCoerce#, error, and (->) are some of these -places. The way we do this is to use levity polymorphism. +places. The way we do this is to use runtime-representation polymorphism. -We have (levityTyCon, liftedDataCon, unliftedDataCon) +We have - data Levity = Lifted | Unlifted + data RuntimeRep = PtrRepLifted | PtrRepUnlifted | ... and a magical constant (tYPETyCon) - TYPE :: Levity -> TYPE Lifted + TYPE :: RuntimeRep -> TYPE PtrRepLifted We then have synonyms (liftedTypeKindTyCon, unliftedTypeKindTyCon) - type Type = TYPE Lifted - type # = TYPE Unlifted + type * = TYPE PtrRepLifted + type # = TYPE PtrRepUnlifted + +The (...) in the definition for RuntimeRep includes possibilities for +the unboxed, unlifted representations, isomorphic to the PrimRep type +in TyCon. RuntimeRep is itself declared in GHC.Types. + +An alternative design would be to have + + data RuntimeRep = PtrRep Levity | ... + data Levity = Lifted | Unlifted -So, for example, we get +but this slowed down GHC because every time we looked at *, we had to +follow a bunch of pointers. When we have unpackable sums, we should +go back to the stratified representation. This would allow, for example: - unsafeCoerce# :: forall (v1 :: Levity) (v2 :: Levity) + unsafeCoerce# :: forall (r1 :: RuntimeRep) (v2 :: Levity) (a :: TYPE v1) (b :: TYPE v2). a -> b -This replaces the old sub-kinding machinery. We call variables `a` and `b` -above "levity polymorphic". +TYPE replaces the old sub-kinding machinery. We call variables `a` and `b` +above "runtime-representation polymorphic". + -} tYPETyCon, unliftedTypeKindTyCon :: TyCon tYPETyConName, unliftedTypeKindTyConName :: Name tYPETyCon = mkKindTyCon tYPETyConName - (ForAllTy (Anon levityTy) liftedTypeKind) + [Anon runtimeRepTy] + liftedTypeKind [Nominal] (mkPrelTyConRepName tYPETyConName) @@ -335,9 +344,9 @@ tYPETyCon = mkKindTyCon tYPETyConName -- 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 unliftedDataConTy) + [] liftedTypeKind + [] [] + (tYPE (TyConApp ptrRepUnliftedDataConTyCon [])) -------------------------- -- ... and now their names @@ -347,9 +356,6 @@ unliftedTypeKindTyCon = mkSynonymTyCon unliftedTypeKindTyConName tYPETyConName = mkPrimTyConName (fsLit "TYPE") tYPETyConKey tYPETyCon unliftedTypeKindTyConName = mkPrimTyConName (fsLit "#") unliftedTypeKindTyConKey unliftedTypeKindTyCon -unliftedTypeKind :: Kind -unliftedTypeKind = tYPE unliftedDataConTy - mkPrimTyConName :: FastString -> Unique -> TyCon -> Name mkPrimTyConName = mkPrimTcName BuiltInSyntax -- All of the super kinds and kinds are defined in Prim, @@ -360,9 +366,9 @@ mkPrimTcName built_in_syntax occ key tycon = mkWiredInName gHC_PRIM (mkTcOccFS occ) key (ATyCon tycon) built_in_syntax ----------------------------- --- | Given a Levity, applies TYPE to it. See Note [TYPE]. +-- | Given a RuntimeRep, applies TYPE to it. See Note [TYPE]. tYPE :: Type -> Type -tYPE lev = TyConApp tYPETyCon [lev] +tYPE rr = TyConApp tYPETyCon [rr] {- ************************************************************************ @@ -375,16 +381,48 @@ tYPE lev = TyConApp tYPETyCon [lev] -- only used herein pcPrimTyCon :: Name -> [Role] -> PrimRep -> TyCon pcPrimTyCon name roles rep - = mkPrimTyCon name kind roles rep + = mkPrimTyCon name binders result_kind roles where - kind = mkFunTys (map (const liftedTypeKind) roles) result_kind - result_kind = unliftedTypeKind + binders = map (const (Anon 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 + pcPrimTyCon0 :: Name -> PrimRep -> TyCon pcPrimTyCon0 name rep - = mkPrimTyCon name result_kind [] rep - where - result_kind = unliftedTypeKind + = pcPrimTyCon name [] rep charPrimTy :: Type charPrimTy = mkTyConTy charPrimTyCon @@ -627,7 +665,7 @@ RealWorld; it's only used in the type system, to parameterise State#. -} realWorldTyCon :: TyCon -realWorldTyCon = mkLiftedPrimTyCon realWorldTyConName liftedTypeKind [] PtrRep +realWorldTyCon = mkLiftedPrimTyCon realWorldTyConName [] liftedTypeKind [] realWorldTy :: Type realWorldTy = mkTyConTy realWorldTyCon realWorldStatePrimTy :: Type @@ -647,11 +685,12 @@ mkProxyPrimTy :: Type -> Type -> Type mkProxyPrimTy k ty = TyConApp proxyPrimTyCon [k, ty] proxyPrimTyCon :: TyCon -proxyPrimTyCon = mkPrimTyCon proxyPrimTyConName kind [Nominal,Nominal] VoidRep - where kind = ForAllTy (Named kv Specified) $ - mkFunTy k unliftedTypeKind - kv = kKiVar - k = mkTyVarTy kv +proxyPrimTyCon = mkPrimTyCon proxyPrimTyConName binders res_kind [Nominal,Nominal] + where binders = [ Named kv Specified + , Anon k ] + res_kind = tYPE voidRepDataConTy + kv = kKiVar + k = mkTyVarTy kv {- ********************************************************************* @@ -663,10 +702,12 @@ proxyPrimTyCon = mkPrimTyCon proxyPrimTyConName kind [Nominal,Nominal] VoidRep eqPrimTyCon :: TyCon -- The representation type for equality predicates -- See Note [The equality types story] -eqPrimTyCon = mkPrimTyCon eqPrimTyConName kind roles VoidRep - where kind = ForAllTy (Named kv1 Specified) $ - ForAllTy (Named kv2 Specified) $ - mkFunTys [k1, k2] unliftedTypeKind +eqPrimTyCon = mkPrimTyCon eqPrimTyConName binders res_kind roles + where binders = [ Named kv1 Specified + , Named kv2 Specified + , Anon k1 + , Anon k2 ] + res_kind = tYPE voidRepDataConTy [kv1, kv2] = mkTemplateTyVars [liftedTypeKind, liftedTypeKind] k1 = mkTyVarTy kv1 k2 = mkTyVarTy kv2 @@ -676,11 +717,12 @@ eqPrimTyCon = mkPrimTyCon eqPrimTyConName kind roles VoidRep -- this should only ever appear as the type of a covar. Its role is -- interpreted in coercionRole eqReprPrimTyCon :: TyCon -- See Note [The equality types story] -eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName kind - roles VoidRep - where kind = ForAllTy (Named kv1 Specified) $ - ForAllTy (Named kv2 Specified) $ - mkFunTys [k1, k2] unliftedTypeKind +eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName binders res_kind roles + where binders = [ Named kv1 Specified + , Named kv2 Specified + , Anon k1 + , Anon k2 ] + res_kind = tYPE voidRepDataConTy [kv1, kv2] = mkTemplateTyVars [liftedTypeKind, liftedTypeKind] k1 = mkTyVarTy kv1 k2 = mkTyVarTy kv2 @@ -690,12 +732,13 @@ eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName kind -- This is only used to make higher-order equalities. Nothing -- should ever actually have this type! eqPhantPrimTyCon :: TyCon -eqPhantPrimTyCon = mkPrimTyCon eqPhantPrimTyConName kind +eqPhantPrimTyCon = mkPrimTyCon eqPhantPrimTyConName binders res_kind [Nominal, Nominal, Phantom, Phantom] - VoidRep - where kind = ForAllTy (Named kv1 Specified) $ - ForAllTy (Named kv2 Specified) $ - mkFunTys [k1, k2] unliftedTypeKind + where binders = [ Named kv1 Specified + , Named kv2 Specified + , Anon k1 + , Anon k2 ] + res_kind = tYPE voidRepDataConTy [kv1, kv2] = mkTemplateTyVars [liftedTypeKind, liftedTypeKind] k1 = mkTyVarTy kv1 k2 = mkTyVarTy kv2 @@ -920,12 +963,13 @@ anyTy :: Type anyTy = mkTyConTy anyTyCon anyTyCon :: TyCon -anyTyCon = mkFamilyTyCon anyTyConName kind [kKiVar] Nothing +anyTyCon = mkFamilyTyCon anyTyConName binders res_kind [kKiVar] Nothing (ClosedSynFamilyTyCon Nothing) Nothing NotInjective where - kind = ForAllTy (Named kKiVar Specified) (mkTyVarTy kKiVar) + binders = [Named kKiVar Specified] + res_kind = mkTyVarTy kKiVar anyTypeOfKind :: Kind -> Type anyTypeOfKind kind = TyConApp anyTyCon [kind] diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs index b7bd186e86..6f0fc569f2 100644 --- a/compiler/prelude/TysWiredIn.hs +++ b/compiler/prelude/TysWiredIn.hs @@ -88,11 +88,25 @@ module TysWiredIn ( mkWiredInIdName, -- used in MkId - -- * Levity - levityTy, levityTyCon, liftedDataCon, unliftedDataCon, - liftedPromDataCon, unliftedPromDataCon, - liftedDataConTy, unliftedDataConTy, - liftedDataConName, unliftedDataConName, + -- * RuntimeRep and friends + runtimeRepTyCon, vecCountTyCon, vecElemTyCon, + + runtimeRepTy, ptrRepLiftedTy, + + vecRepDataConTyCon, ptrRepUnliftedDataConTyCon, + + voidRepDataConTy, intRepDataConTy, + wordRepDataConTy, int64RepDataConTy, word64RepDataConTy, addrRepDataConTy, + floatRepDataConTy, doubleRepDataConTy, unboxedTupleRepDataConTy, + + vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, + vec64DataConTy, + + int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, + int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, + word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, + doubleElemRepDataConTy + ) where #include "HsVersions.h" @@ -135,6 +149,15 @@ alpha_ty :: [Type] alpha_ty = [alphaTy] {- +Note [Wiring in RuntimeRep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The RuntimeRep type (and friends) in GHC.Types has a bunch of constructors, +making it a pain to wire in. To ease the pain somewhat, we use lists of +the different bits, like Uniques, Names, DataCons. These lists must be +kept in sync with each other. The rule is this: use the order as declared +in GHC.Types. All places where such lists exist should contain a reference +to this Note, so a search for this Note's name should find all the lists. + ************************************************************************ * * \subsection{Wired in type constructors} @@ -178,7 +201,9 @@ wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because , coercibleTyCon , typeNatKindCon , typeSymbolKindCon - , levityTyCon + , runtimeRepTyCon + , vecCountTyCon + , vecElemTyCon , constraintKindTyCon , liftedTypeKindTyCon , starKindTyCon @@ -264,10 +289,48 @@ liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type") starKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "*") starKindTyConKey starKindTyCon unicodeStarKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "★") unicodeStarKindTyConKey unicodeStarKindTyCon -levityTyConName, liftedDataConName, unliftedDataConName :: Name -levityTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Levity") levityTyConKey levityTyCon -liftedDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Lifted") liftedDataConKey liftedDataCon -unliftedDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Unlifted") unliftedDataConKey unliftedDataCon +runtimeRepTyConName, vecRepDataConName :: Name +runtimeRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeRep") runtimeRepTyConKey runtimeRepTyCon +vecRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "VecRep") vecRepDataConKey vecRepDataCon + +-- See Note [Wiring in RuntimeRep] +runtimeRepSimpleDataConNames :: [Name] +runtimeRepSimpleDataConNames + = zipWith3Lazy mk_special_dc_name + [ fsLit "PtrRepLifted", fsLit "PtrRepUnlifted" + , fsLit "VoidRep", fsLit "IntRep" + , fsLit "WordRep", fsLit "Int64Rep", fsLit "Word64Rep" + , fsLit "AddrRep", fsLit "FloatRep", fsLit "DoubleRep" + , fsLit "UnboxedTupleRep" ] + runtimeRepSimpleDataConKeys + runtimeRepSimpleDataCons + +vecCountTyConName :: Name +vecCountTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecCount") vecCountTyConKey vecCountTyCon + +-- See Note [Wiring in RuntimeRep] +vecCountDataConNames :: [Name] +vecCountDataConNames = zipWith3Lazy mk_special_dc_name + [ fsLit "Vec2", fsLit "Vec4", fsLit "Vec8" + , fsLit "Vec16", fsLit "Vec32", fsLit "Vec64" ] + vecCountDataConKeys + vecCountDataCons + +vecElemTyConName :: Name +vecElemTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecElem") vecElemTyConKey vecElemTyCon + +-- See Note [Wiring in RuntimeRep] +vecElemDataConNames :: [Name] +vecElemDataConNames = zipWith3Lazy mk_special_dc_name + [ fsLit "Int8ElemRep", fsLit "Int16ElemRep", fsLit "Int32ElemRep" + , fsLit "Int64ElemRep", fsLit "Word8ElemRep", fsLit "Word16elemRep" + , fsLit "Word32ElemRep", fsLit "Word64ElemRep" + , fsLit "FloatElemRep", fsLit "DoubleElemRep" ] + vecElemDataConKeys + vecElemDataCons + +mk_special_dc_name :: FastString -> Unique -> DataCon -> Name +mk_special_dc_name fs u dc = mkWiredInDataConName UserSyntax gHC_TYPES fs u dc parrTyConName, parrDataConName :: Name parrTyConName = mkWiredInTyConName BuiltInSyntax @@ -304,7 +367,8 @@ pcNonRecDataTyCon = pcTyCon False NonRecursive pcTyCon :: Bool -> RecFlag -> Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon pcTyCon is_enum is_rec name cType tyvars cons = mkAlgTyCon name - (mkFunTys (map tyVarKind tyvars) liftedTypeKind) + (map (mkAnonBinder . tyVarKind) tyvars) + liftedTypeKind tyvars (map (const Representational) tyvars) cType @@ -325,6 +389,7 @@ pcDataConWithFixity :: Bool -- ^ declared infix? -> TyCon -> DataCon pcDataConWithFixity infx n = pcDataConWithFixity' infx n (incrUnique (nameUnique n)) + NoRRI -- The Name's unique is the first of two free uniques; -- the first is used for the datacon itself, -- the second is used for the "worker name" @@ -332,12 +397,13 @@ pcDataConWithFixity infx n = pcDataConWithFixity' infx n (incrUnique (nameUnique -- To support this the mkPreludeDataConUnique function "allocates" -- one DataCon unique per pair of Ints. -pcDataConWithFixity' :: Bool -> Name -> Unique -> [TyVar] -> [TyVar] +pcDataConWithFixity' :: Bool -> Name -> Unique -> RuntimeRepInfo + -> [TyVar] -> [TyVar] -> [Type] -> TyCon -> DataCon -- The Name should be in the DataName name space; it's the name -- of the DataCon itself. -pcDataConWithFixity' declared_infix dc_name wrk_key tyvars ex_tyvars arg_tys tycon +pcDataConWithFixity' declared_infix dc_name wrk_key rri tyvars ex_tyvars arg_tys tycon = data_con where data_con = mkDataCon dc_name declared_infix prom_info @@ -348,6 +414,7 @@ pcDataConWithFixity' declared_infix dc_name wrk_key tyvars ex_tyvars arg_tys tyc [] -- No equality spec [] -- No theta arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)) + rri tycon [] -- No stupid theta (mkDataConWorkId wrk_name data_con) @@ -364,6 +431,12 @@ pcDataConWithFixity' declared_infix dc_name wrk_key tyvars ex_tyvars arg_tys tyc prom_info = mkPrelTyConRepName dc_name +-- used for RuntimeRep and friends +pcSpecialDataCon :: Name -> [Type] -> TyCon -> RuntimeRepInfo -> DataCon +pcSpecialDataCon dc_name arg_tys tycon rri + = pcDataConWithFixity' False dc_name (incrUnique (nameUnique dc_name)) rri + [] [] arg_tys tycon + {- ************************************************************************ * * @@ -387,7 +460,7 @@ constraintKindTyCon = pcTyCon False NonRecursive constraintKindTyConName Nothing [] [] liftedTypeKind, constraintKind :: Kind -liftedTypeKind = tYPE liftedDataConTy +liftedTypeKind = tYPE ptrRepLiftedTy constraintKind = mkTyConApp constraintKindTyCon [] @@ -536,34 +609,38 @@ unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mA mk_tuple :: Boxity -> Int -> (TyCon,DataCon) mk_tuple boxity arity = (tycon, tuple_con) where - tycon = mkTupleTyCon tc_name tc_kind tc_arity tyvars tuple_con + tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tc_arity tyvars tuple_con tup_sort flavour - (tup_sort, modu, tc_kind, tc_arity, tyvars, tyvar_tys, flavour) + (tup_sort, modu, tc_binders, tc_res_kind, tc_arity, tyvars, tyvar_tys, flavour) = case boxity of Boxed -> let boxed_tyvars = take arity alphaTyVars in ( BoxedTuple , gHC_TUPLE - , mkFunTys (nOfThem arity liftedTypeKind) liftedTypeKind + , nOfThem arity (mkAnonBinder liftedTypeKind) + , liftedTypeKind , arity , boxed_tyvars , mkTyVarTys boxed_tyvars , VanillaAlgTyCon (mkPrelTyConRepName tc_name) ) - -- See Note [Unboxed tuple levity vars] in TyCon + -- See Note [Unboxed tuple RuntimeRep vars] in TyCon Unboxed -> - let all_tvs = mkTemplateTyVars (replicate arity levityTy ++ + let all_tvs = mkTemplateTyVars (replicate arity runtimeRepTy ++ map (tYPE . mkTyVarTy) (take arity all_tvs)) -- NB: This must be one call to mkTemplateTyVars, to make -- sure that all the uniques are different - (lev_tvs, open_tvs) = splitAt arity all_tvs + (rr_tvs, open_tvs) = splitAt arity all_tvs + res_rep | arity == 0 = voidRepDataConTy + -- See Note [Nullary unboxed tuple] in Type + | otherwise = unboxedTupleRepDataConTy in ( UnboxedTuple , gHC_PRIM - , mkSpecForAllTys lev_tvs $ - mkFunTys (map tyVarKind open_tvs) $ - unliftedTypeKind + , map (mkNamedBinder Specified) rr_tvs ++ + map (mkAnonBinder . tyVarKind) open_tvs + , tYPE res_rep , arity * 2 , all_tvs , mkTyVarTys open_tvs @@ -616,13 +693,16 @@ heqSCSelId, coercibleSCSelId :: Id (heqTyCon, heqClass, heqDataCon, heqSCSelId) = (tycon, klass, datacon, sc_sel_id) where - tycon = mkClassTyCon heqTyConName kind tvs roles + tycon = mkClassTyCon heqTyConName binders tvs roles rhs klass NonRecursive (mkPrelTyConRepName heqTyConName) klass = mkClass tvs [] [sc_pred] [sc_sel_id] [] [] (mkAnd []) tycon datacon = pcDataCon heqDataConName tvs [sc_pred] tycon - kind = mkSpecForAllTys [kv1, kv2] $ mkFunTys [k1, k2] constraintKind + binders = [ mkNamedBinder Specified kv1 + , mkNamedBinder Specified kv2 + , mkAnonBinder k1 + , mkAnonBinder k2 ] kv1:kv2:_ = drop 9 alphaTyVars -- gets "j" and "k" k1 = mkTyVarTy kv1 k2 = mkTyVarTy kv2 @@ -637,13 +717,15 @@ heqSCSelId, coercibleSCSelId :: Id (coercibleTyCon, coercibleClass, coercibleDataCon, coercibleSCSelId) = (tycon, klass, datacon, sc_sel_id) where - tycon = mkClassTyCon coercibleTyConName kind tvs roles + tycon = mkClassTyCon coercibleTyConName binders tvs roles rhs klass NonRecursive (mkPrelTyConRepName coercibleTyConName) klass = mkClass tvs [] [sc_pred] [sc_sel_id] [] [] (mkAnd []) tycon datacon = pcDataCon coercibleDataConName tvs [sc_pred] tycon - kind = mkSpecForAllTys [kKiVar] $ mkFunTys [k, k] constraintKind + binders = [ mkNamedBinder Specified kKiVar + , mkAnonBinder k + , mkAnonBinder k ] k = mkTyVarTy kKiVar [av,bv] = mkTemplateTyVars [k, k] tvs = [kKiVar, av, bv] @@ -656,48 +738,125 @@ heqSCSelId, coercibleSCSelId :: Id {- ********************************************************************* * * - Kinds and levity + Kinds and RuntimeRep * * ********************************************************************* -} -- For information about the usage of the following type, see Note [TYPE] -- in module TysPrim -levityTy :: Type -levityTy = mkTyConTy levityTyCon - -levityTyCon :: TyCon -levityTyCon = pcTyCon True NonRecursive levityTyConName - Nothing [] [liftedDataCon, unliftedDataCon] - -liftedDataCon, unliftedDataCon :: DataCon -liftedDataCon = pcDataCon liftedDataConName [] [] levityTyCon -unliftedDataCon = pcDataCon unliftedDataConName [] [] levityTyCon - -liftedPromDataCon, unliftedPromDataCon :: TyCon -liftedPromDataCon = promoteDataCon liftedDataCon -unliftedPromDataCon = promoteDataCon unliftedDataCon - -liftedDataConTy, unliftedDataConTy :: Type -liftedDataConTy = mkTyConTy liftedPromDataCon -unliftedDataConTy = mkTyConTy unliftedPromDataCon +runtimeRepTy :: Type +runtimeRepTy = mkTyConTy runtimeRepTyCon liftedTypeKindTyCon, starKindTyCon, unicodeStarKindTyCon :: TyCon -- See Note [TYPE] in TysPrim liftedTypeKindTyCon = mkSynonymTyCon liftedTypeKindTyConName - liftedTypeKind + [] liftedTypeKind [] [] - (tYPE liftedDataConTy) + (tYPE ptrRepLiftedTy) starKindTyCon = mkSynonymTyCon starKindTyConName - liftedTypeKind + [] liftedTypeKind [] [] - (tYPE liftedDataConTy) + (tYPE ptrRepLiftedTy) unicodeStarKindTyCon = mkSynonymTyCon unicodeStarKindTyConName - liftedTypeKind + [] liftedTypeKind [] [] - (tYPE liftedDataConTy) + (tYPE ptrRepLiftedTy) + +runtimeRepTyCon :: TyCon +runtimeRepTyCon = pcNonRecDataTyCon runtimeRepTyConName Nothing [] + (vecRepDataCon : runtimeRepSimpleDataCons) + +vecRepDataCon :: DataCon +vecRepDataCon = pcSpecialDataCon vecRepDataConName [ mkTyConTy vecCountTyCon + , mkTyConTy vecElemTyCon ] + runtimeRepTyCon + (RuntimeRep prim_rep_fun) + where + prim_rep_fun [count, elem] + | VecCount n <- tyConRuntimeRepInfo (tyConAppTyCon count) + , VecElem e <- tyConRuntimeRepInfo (tyConAppTyCon elem) + = VecRep n e + prim_rep_fun args + = pprPanic "vecRepDataCon" (ppr args) + +vecRepDataConTyCon :: TyCon +vecRepDataConTyCon = promoteDataCon vecRepDataCon + +ptrRepUnliftedDataConTyCon :: TyCon +ptrRepUnliftedDataConTyCon = promoteDataCon ptrRepUnliftedDataCon + +-- See Note [Wiring in RuntimeRep] +runtimeRepSimpleDataCons :: [DataCon] +ptrRepLiftedDataCon, ptrRepUnliftedDataCon :: DataCon +runtimeRepSimpleDataCons@(ptrRepLiftedDataCon : ptrRepUnliftedDataCon : _) + = zipWithLazy mk_runtime_rep_dc + [ PtrRep, PtrRep, VoidRep, IntRep, WordRep, Int64Rep + , Word64Rep, AddrRep, FloatRep, DoubleRep + , panic "unboxed tuple PrimRep" ] + runtimeRepSimpleDataConNames + where + mk_runtime_rep_dc primrep name + = pcSpecialDataCon name [] runtimeRepTyCon (RuntimeRep (\_ -> primrep)) + +-- See Note [Wiring in RuntimeRep] +voidRepDataConTy, intRepDataConTy, wordRepDataConTy, int64RepDataConTy, + word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy, + unboxedTupleRepDataConTy :: Type +[_, _, voidRepDataConTy, intRepDataConTy, wordRepDataConTy, int64RepDataConTy, + word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy, + unboxedTupleRepDataConTy] = map (mkTyConTy . promoteDataCon) + runtimeRepSimpleDataCons + +vecCountTyCon :: TyCon +vecCountTyCon = pcNonRecDataTyCon vecCountTyConName Nothing [] + vecCountDataCons + +-- See Note [Wiring in RuntimeRep] +vecCountDataCons :: [DataCon] +vecCountDataCons = zipWithLazy mk_vec_count_dc + [ 2, 4, 8, 16, 32, 64 ] + vecCountDataConNames + where + mk_vec_count_dc n name + = pcSpecialDataCon name [] vecCountTyCon (VecCount n) + +-- See Note [Wiring in RuntimeRep] +vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, + vec64DataConTy :: Type +[vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, + vec64DataConTy] = map (mkTyConTy . promoteDataCon) vecCountDataCons + +vecElemTyCon :: TyCon +vecElemTyCon = pcNonRecDataTyCon vecElemTyConName Nothing [] vecElemDataCons + +-- See Note [Wiring in RuntimeRep] +vecElemDataCons :: [DataCon] +vecElemDataCons = zipWithLazy mk_vec_elem_dc + [ Int8ElemRep, Int16ElemRep, Int32ElemRep, Int64ElemRep + , Word8ElemRep, Word16ElemRep, Word32ElemRep, Word64ElemRep + , FloatElemRep, DoubleElemRep ] + vecElemDataConNames + where + mk_vec_elem_dc elem name + = pcSpecialDataCon name [] vecElemTyCon (VecElem elem) + +-- See Note [Wiring in RuntimeRep] +int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, + int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, + word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, + doubleElemRepDataConTy :: Type +[int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, + int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, + word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, + doubleElemRepDataConTy] = map (mkTyConTy . promoteDataCon) + vecElemDataCons + +-- The type ('PtrRepLifted) +ptrRepLiftedTy :: Type +ptrRepLiftedTy = mkTyConTy $ promoteDataCon ptrRepLiftedDataCon {- ********************************************************************* * * @@ -943,13 +1102,13 @@ done by enumeration\srcloc{lib/prelude/InTup?.hs}. -} -- | Make a tuple type. The list of types should /not/ include any --- levity specifications. +-- RuntimeRep specifications. mkTupleTy :: Boxity -> [Type] -> Type -- Special case for *boxed* 1-tuples, which are represented by the type itself mkTupleTy Boxed [ty] = ty mkTupleTy Boxed tys = mkTyConApp (tupleTyCon Boxed (length tys)) tys mkTupleTy Unboxed tys = mkTyConApp (tupleTyCon Unboxed (length tys)) - (map (getLevity "mkTupleTy") tys ++ tys) + (map (getRuntimeRep "mkTupleTy") tys ++ tys) -- | Build the type of a small tuple that holds the specified type of thing mkBoxedTupleTy :: [Type] -> Type diff --git a/compiler/prelude/TysWiredIn.hs-boot b/compiler/prelude/TysWiredIn.hs-boot index f7ae6354b3..7216d2667c 100644 --- a/compiler/prelude/TysWiredIn.hs-boot +++ b/compiler/prelude/TysWiredIn.hs-boot @@ -1,6 +1,6 @@ module TysWiredIn where -import TyCon +import {-# SOURCE #-} TyCon ( TyCon ) import {-# SOURCE #-} TyCoRep (Type, Kind) @@ -8,6 +8,22 @@ listTyCon :: TyCon typeNatKind, typeSymbolKind :: Type mkBoxedTupleTy :: [Type] -> Type -levityTy, unliftedDataConTy :: Type - liftedTypeKind :: Kind +constraintKind :: Kind + +runtimeRepTyCon, vecCountTyCon, vecElemTyCon :: TyCon +runtimeRepTy :: Type + +ptrRepUnliftedDataConTyCon, vecRepDataConTyCon :: TyCon + +voidRepDataConTy, intRepDataConTy, + wordRepDataConTy, int64RepDataConTy, word64RepDataConTy, addrRepDataConTy, + floatRepDataConTy, doubleRepDataConTy, unboxedTupleRepDataConTy :: Type + +vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, + vec64DataConTy :: Type + +int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, + int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, + word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, + doubleElemRepDataConTy :: Type diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs index b3da5ef5ea..498687efb2 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -14,6 +14,8 @@ module Inst ( instCall, instDFunType, instStupidTheta, newWanted, newWanteds, + tcInstBinders, tcInstBindersX, + newOverloadedLit, mkOverLit, newClsInst, @@ -30,7 +32,7 @@ module Inst ( #include "HsVersions.h" import {-# SOURCE #-} TcExpr( tcPolyExpr, tcSyntaxOp ) -import {-# SOURCE #-} TcUnify( unifyType, noThing ) +import {-# SOURCE #-} TcUnify( unifyType, unifyKind, noThing ) import FastString import HsSyn @@ -39,8 +41,7 @@ import TcRnMonad import TcEnv import TcEvidence import InstEnv -import DataCon ( dataConWrapId ) -import TysWiredIn ( heqDataCon ) +import TysWiredIn ( heqDataCon, coercibleDataCon ) import CoreSyn ( isOrphan ) import FunDeps import TcMType @@ -51,7 +52,9 @@ import Class( Class ) import MkId( mkDictFunId ) import Id import Name -import Var ( EvVar ) +import Var ( EvVar, mkTyVar ) +import DataCon +import TyCon import VarEnv import PrelNames import SrcLoc @@ -326,6 +329,122 @@ instStupidTheta orig theta = do { _co <- instCallConstraints orig theta -- Discard the coercion ; return () } +{- +************************************************************************ +* * + Instantiating Kinds +* * +************************************************************************ + +-} + +--------------------------- +-- | This is used to instantiate binders when type-checking *types* only. +-- See also Note [Bidirectional type checking] +tcInstBinders :: [TyBinder] -> TcM (TCvSubst, [TcType]) +tcInstBinders = tcInstBindersX emptyTCvSubst Nothing + +-- | This is used to instantiate binders when type-checking *types* only. +-- The @VarEnv Kind@ gives some known instantiations. +-- See also Note [Bidirectional type checking] +tcInstBindersX :: TCvSubst -> Maybe (VarEnv Kind) + -> [TyBinder] -> TcM (TCvSubst, [TcType]) +tcInstBindersX subst mb_kind_info bndrs + = do { (subst, args) <- mapAccumLM (tcInstBinderX mb_kind_info) subst bndrs + ; traceTc "instantiating tybinders:" + (vcat $ zipWith (\bndr arg -> ppr bndr <+> text ":=" <+> ppr arg) + bndrs args) + ; return (subst, args) } + +-- | Used only in *types* +tcInstBinderX :: Maybe (VarEnv Kind) + -> TCvSubst -> TyBinder -> TcM (TCvSubst, TcType) +tcInstBinderX mb_kind_info subst binder + | Just tv <- binderVar_maybe binder + = case lookup_tv tv of + Just ki -> return (extendTvSubstAndInScope subst tv ki, ki) + Nothing -> do { (subst', tv') <- newMetaTyVarX subst tv + ; return (subst', mkTyVarTy tv') } + + -- This is the *only* constraint currently handled in types. + | Just (mk, role, k1, k2) <- get_pred_tys_maybe substed_ty + = do { let origin = TypeEqOrigin { uo_actual = k1 + , uo_expected = mkCheckExpType k2 + , uo_thing = Nothing } + ; co <- case role of + Nominal -> unifyKind noThing k1 k2 + Representational -> emitWantedEq origin KindLevel role k1 k2 + Phantom -> pprPanic "tcInstBinderX Phantom" (ppr binder) + ; arg' <- mk co k1 k2 + ; return (subst, arg') } + + | isPredTy substed_ty + = do { let (env, tidy_ty) = tidyOpenType emptyTidyEnv substed_ty + ; addErrTcM (env, text "Illegal constraint in a type:" <+> ppr tidy_ty) + + -- just invent a new variable so that we can continue + ; u <- newUnique + ; let name = mkSysTvName u (fsLit "dict") + ; return (subst, mkTyVarTy $ mkTyVar name substed_ty) } + + + | otherwise + = do { ty <- newFlexiTyVarTy substed_ty + ; return (subst, ty) } + + where + substed_ty = substTy subst (binderType binder) + + lookup_tv tv = do { env <- mb_kind_info -- `Maybe` monad + ; lookupVarEnv env tv } + + -- handle boxed equality constraints, because it's so easy + get_pred_tys_maybe ty + | Just (r, k1, k2) <- getEqPredTys_maybe ty + = Just (\co _ _ -> return $ mkCoercionTy co, r, k1, k2) + | Just (tc, [_, _, k1, k2]) <- splitTyConApp_maybe ty + = if | tc `hasKey` heqTyConKey + -> Just (mkHEqBoxTy, Nominal, k1, k2) + | otherwise + -> Nothing + | Just (tc, [_, k1, k2]) <- splitTyConApp_maybe ty + = if | tc `hasKey` eqTyConKey + -> Just (mkEqBoxTy, Nominal, k1, k2) + | tc `hasKey` coercibleTyConKey + -> Just (mkCoercibleBoxTy, Representational, k1, k2) + | otherwise + -> Nothing + | otherwise + = Nothing + +------------------------------- +-- | This takes @a ~# b@ and returns @a ~~ b@. +mkHEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type +-- monadic just for convenience with mkEqBoxTy +mkHEqBoxTy co ty1 ty2 + = return $ + mkTyConApp (promoteDataCon heqDataCon) [k1, k2, ty1, ty2, mkCoercionTy co] + where k1 = typeKind ty1 + k2 = typeKind ty2 + +-- | This takes @a ~# b@ and returns @a ~ b@. +mkEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type +mkEqBoxTy co ty1 ty2 + = do { eq_tc <- tcLookupTyCon eqTyConName + ; let [datacon] = tyConDataCons eq_tc + ; hetero <- mkHEqBoxTy co ty1 ty2 + ; return $ mkTyConApp (promoteDataCon datacon) [k, ty1, ty2, hetero] } + where k = typeKind ty1 + +-- | This takes @a ~R# b@ and returns @Coercible a b@. +mkCoercibleBoxTy :: TcCoercion -> Type -> Type -> TcM Type +-- monadic just for convenience with mkEqBoxTy +mkCoercibleBoxTy co ty1 ty2 + = do { return $ + mkTyConApp (promoteDataCon coercibleDataCon) + [k, ty1, ty2, mkCoercionTy co] } + where k = typeKind ty1 + {- ************************************************************************ * * diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index 43f933b70d..495a442fa1 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -963,7 +963,7 @@ recoveryCode binder_names sig_fn = mkLocalId name forall_a_a forall_a_a :: TcType -forall_a_a = mkSpecForAllTys [levity1TyVar, openAlphaTyVar] openAlphaTy +forall_a_a = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] openAlphaTy {- ********************************************************************* * * diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs index 75996f8163..2da3153c3c 100644 --- a/compiler/typecheck/TcCanonical.hs +++ b/compiler/typecheck/TcCanonical.hs @@ -1134,7 +1134,7 @@ canDecomposableTyConAppOK ev eq_rel tc tys1 tys2 -- the following makes a better distinction between "kind" and "type" -- in error messages - (bndrs, _) = splitPiTys (tyConKind tc) + bndrs = tyConBinders tc kind_loc = toKindLoc loc is_kinds = map isNamedBinder bndrs new_locs | Just KindLevel <- ctLocTypeOrKind_maybe loc @@ -1962,10 +1962,8 @@ unify_derived loc role orig_ty1 orig_ty2 Nothing -> bale_out } go _ _ = bale_out - -- no point in having *boxed* deriveds. bale_out = emitNewDerivedEq loc role orig_ty1 orig_ty2 maybeSym :: SwapFlag -> TcCoercion -> TcCoercion maybeSym IsSwapped co = mkTcSymCo co maybeSym NotSwapped co = co - diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index 56772f2b1a..c2b344dd77 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -934,7 +934,7 @@ inferConstraints main_cls cls_tys inst_ty rep_tc rep_tc_args ++ sc_constraints ++ arg_constraints) } where - (tc_binders, _) = splitPiTys (tyConKind rep_tc) + tc_binders = tyConBinders rep_tc choose_level bndr | isNamedBinder bndr = KindLevel | otherwise = TypeLevel diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index 2140a797ff..daae2021e8 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -29,8 +29,8 @@ import DataCon import TcEvidence import Name import RdrName ( lookupGRE_Name, GlobalRdrEnv, mkRdrUnqual ) -import PrelNames ( typeableClassName, hasKey - , liftedDataConKey, unliftedDataConKey ) +import PrelNames ( typeableClassName, hasKey, ptrRepLiftedDataConKey + , ptrRepUnliftedDataConKey ) import Id import Var import VarSet @@ -1366,12 +1366,22 @@ misMatchMsg ct oriented ty1 ty2 | Just NotSwapped <- oriented = 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 + -- lifted vs. unlifted + | Just (tc1, []) <- splitTyConApp_maybe ty1 + , tc1 `hasKey` ptrRepLiftedDataConKey + = 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` liftedDataConKey && tc2 `hasKey` unliftedDataConKey) || - (tc2 `hasKey` liftedDataConKey && tc1 `hasKey` unliftedDataConKey) - = addArising orig $ - text "Couldn't match a lifted type with an unlifted type" + , (tc1 `hasKey` ptrRepLiftedDataConKey && tc2 `hasKey` ptrRepUnliftedDataConKey) + || (tc1 `hasKey` ptrRepUnliftedDataConKey && tc2 `hasKey` ptrRepLiftedDataConKey) + = lifted_vs_unlifted | otherwise -- So now we have Nothing or (Just IsSwapped) -- For some reason we treat Nothing like IsSwapped @@ -1406,6 +1416,10 @@ misMatchMsg ct oriented ty1 ty2 | null s2 = s1 | otherwise = s1 ++ (' ' : s2) + lifted_vs_unlifted + = addArising orig $ + text "Couldn't match a lifted type with an unlifted type" + mkExpectedActualMsg :: Type -> Type -> CtOrigin -> Maybe TypeOrKind -> Bool -> (Bool, Maybe SwapFlag, SDoc) -- NotSwapped means (actual, expected), IsSwapped is the reverse diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index d54fbc7644..6d5fe09bb9 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -361,7 +361,7 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty ; arg2' <- tcArg op arg2 arg2_sigma 2 -- Make sure that the argument type has kind '*' - -- ($) :: forall (v:Levity) (a:*) (b:TYPE v). (a->b) -> a -> b + -- ($) :: forall (r:RuntimeRep) (a:*) (b:TYPE r). (a->b) -> a -> b -- Eg we do not want to allow (D# $ 4.0#) Trac #5570 -- (which gives a seg fault) -- @@ -378,7 +378,7 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty ; op_id <- tcLookupId op_name ; res_ty <- readExpType res_ty - ; let op' = L loc (HsWrap (mkWpTyApps [ getLevity "tcExpr ($)" res_ty + ; let op' = L loc (HsWrap (mkWpTyApps [ getRuntimeRep "tcExpr ($)" res_ty , arg2_sigma , res_ty]) (HsVar (L lv op_id))) @@ -443,9 +443,9 @@ tcExpr expr@(ExplicitTuple tup_args boxity) res_ty tup_tc = tupleTyCon boxity arity ; res_ty <- expTypeToType res_ty ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty - -- Unboxed tuples have levity vars, which we + -- Unboxed tuples have RuntimeRep vars, which we -- don't care about here - -- See Note [Unboxed tuple levity vars] in TyCon + -- See Note [Unboxed tuple RuntimeRep vars] in TyCon ; let arg_tys' = case boxity of Unboxed -> drop arity arg_tys Boxed -> arg_tys ; tup_args1 <- tcTupArgs tup_args arg_tys' @@ -1663,8 +1663,8 @@ tcSeq loc fun_name args res_ty ; (arg1, arg2, arg2_exp_ty) <- case args1 of [ty_arg_expr2, term_arg1, term_arg2] | Just hs_ty_arg2 <- isLHsTypeExpr_maybe ty_arg_expr2 - -> do { lev_ty <- newFlexiTyVarTy levityTy - ; ty_arg2 <- tcHsTypeApp hs_ty_arg2 (tYPE lev_ty) + -> do { rr_ty <- newFlexiTyVarTy runtimeRepTy + ; ty_arg2 <- tcHsTypeApp hs_ty_arg2 (tYPE rr_ty) -- see Note [Typing rule for seq] ; _ <- tcSubTypeDS GenSigCtxt noThing ty_arg2 res_ty ; return (term_arg1, term_arg2, mkCheckExpType ty_arg2) } diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 66fe38ad8f..d7d23a2a81 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -9,7 +9,7 @@ This module is an extension of @HsSyn@ syntax, for use in the type checker. -} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, TupleSections #-} module TcHsSyn ( mkHsConApp, mkHsDictLet, mkHsApp, @@ -29,7 +29,7 @@ module TcHsSyn ( zonkTopBndrs, zonkTyBndrsX, emptyZonkEnv, mkEmptyZonkEnv, zonkTcTypeToType, zonkTcTypeToTypes, zonkTyVarOcc, - zonkCoToCo + zonkCoToCo, zonkTcKindToKind ) where #include "HsVersions.h" @@ -44,6 +44,7 @@ import TcEvidence import TysPrim import TysWiredIn import Type +import TyCoRep ( TyBinder(..) ) import Coercion import ConLike import DataCon @@ -328,6 +329,15 @@ zonkTyBndrX env tv ; let tv' = mkTyVar (tyVarName tv) ki ; return (extendTyZonkEnv1 env tv', tv') } +zonkTyBinders :: ZonkEnv -> [TcTyBinder] -> TcM (ZonkEnv, [TyBinder]) +zonkTyBinders = mapAccumLM zonkTyBinder + +zonkTyBinder :: ZonkEnv -> TcTyBinder -> TcM (ZonkEnv, TyBinder) +zonkTyBinder env (Anon ty) = (env, ) <$> (Anon <$> zonkTcTypeToType env ty) +zonkTyBinder env (Named tv vis) + = do { (env', tv') <- zonkTyBndrX env tv + ; return (env', Named tv' vis) } + zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id) zonkTopExpr e = zonkExpr emptyZonkEnv e @@ -1582,6 +1592,14 @@ zonkTcTypeToType = mapType zonk_tycomapper zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type] zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys +-- | Used during kind-checking in TcTyClsDecls, where it's more convenient +-- to keep the binders and result kind separate. +zonkTcKindToKind :: [TcTyBinder] -> TcKind -> TcM ([TyBinder], Kind) +zonkTcKindToKind binders res_kind + = do { (env, binders') <- zonkTyBinders emptyZonkEnv binders + ; res_kind' <- zonkTcTypeToType env res_kind + ; return (binders', res_kind') } + zonkCoToCo :: ZonkEnv -> Coercion -> TcM Coercion zonkCoToCo = mapCoercion zonk_tycomapper @@ -1604,7 +1622,7 @@ zonkTypeZapping :: UnboundTyVarZonker -- It zaps unbound type variables to (), or some other arbitrary type -- Works on both types and kinds zonkTypeZapping tv - = do { let ty | isLevityVar tv = liftedDataConTy - | otherwise = anyTypeOfKind (tyVarKind tv) + = do { let ty | isRuntimeRepVar tv = ptrRepLiftedTy + | otherwise = anyTypeOfKind (tyVarKind tv) ; writeMetaTyVar tv ty ; return ty } diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index c7b1470ab1..5b0d9b9e8c 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -54,6 +54,7 @@ import TcUnify import TcIface import TcSimplify ( solveEqualities ) import TcType +import Inst ( tcInstBinders, tcInstBindersX ) import Type import Kind import RdrName( lookupLocalRdrOcc ) @@ -185,8 +186,8 @@ tcHsSigType ctxt sig_ty do { kind <- case expectedKindInCtxt ctxt of AnythingKind -> newMetaKindVar TheKind k -> return k - OpenKind -> do { lev <- newFlexiTyVarTy levityTy - ; return $ tYPE lev } + OpenKind -> do { rr <- newFlexiTyVarTy runtimeRepTy + ; return $ tYPE rr } -- The kind is checked by checkValidType, and isn't necessarily -- of kind * in a Template Haskell quote eg [t| Maybe |] @@ -459,10 +460,10 @@ tc_lhs_type mode (L span ty) exp_kind ------------------------------------------ tc_fun_type :: TcTyMode -> LHsType Name -> LHsType Name -> TcKind -> TcM TcType tc_fun_type mode ty1 ty2 exp_kind - = do { arg_lev <- newFlexiTyVarTy levityTy - ; res_lev <- newFlexiTyVarTy levityTy - ; ty1' <- tc_lhs_type mode ty1 (tYPE arg_lev) - ; ty2' <- tc_lhs_type mode ty2 (tYPE res_lev) + = do { arg_rr <- newFlexiTyVarTy runtimeRepTy + ; res_rr <- newFlexiTyVarTy runtimeRepTy + ; ty1' <- tc_lhs_type mode ty1 (tYPE arg_rr) + ; ty2' <- tc_lhs_type mode ty2 (tYPE res_rr) ; checkExpectedKind (mkFunTy ty1' ty2') liftedTypeKind exp_kind } ------------------------------------------ @@ -657,8 +658,8 @@ tc_tuple :: TcTyMode -> TupleSort -> [LHsType Name] -> TcKind -> TcM TcType tc_tuple mode tup_sort tys exp_kind = do { arg_kinds <- case tup_sort of BoxedTuple -> return (nOfThem arity liftedTypeKind) - UnboxedTuple -> do { levs <- newFlexiTyVarTys arity levityTy - ; return $ map tYPE levs } + UnboxedTuple -> do { rrs <- newFlexiTyVarTys arity runtimeRepTy + ; return $ map tYPE rrs } ConstraintTuple -> return (nOfThem arity constraintKind) ; tau_tys <- zipWithM (tc_lhs_type mode) tys arg_kinds ; finish_tuple tup_sort tau_tys arg_kinds exp_kind } @@ -673,8 +674,8 @@ finish_tuple :: TupleSort 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 levity vars] in TyCon - UnboxedTuple -> map (getLevityFromKind "finish_tuple") tau_kinds + -- See also Note [Unboxed tuple RuntimeRep vars] in TyCon + UnboxedTuple -> map (getRuntimeRepFromKind "finish_tuple") tau_kinds ++ tau_tys BoxedTuple -> tau_tys ConstraintTuple -> tau_tys @@ -691,7 +692,7 @@ finish_tuple tup_sort tau_tys tau_kinds exp_kind where arity = length tau_tys res_kind = case tup_sort of - UnboxedTuple -> unliftedTypeKind + UnboxedTuple -> tYPE unboxedTupleRepDataConTy BoxedTuple -> liftedTypeKind ConstraintTuple -> constraintKind @@ -712,19 +713,21 @@ bigConstraintTuple arity -- the visible ones. tcInferArgs :: Outputable fun => fun -- ^ the function - -> TcKind -- ^ function kind (zonked) + -> [TyBinder] -- ^ function kind's binders -> Maybe (VarEnv Kind) -- ^ possibly, kind info (see above) -> [LHsType Name] -- ^ args - -> TcM (TcKind, [TcType], [LHsType Name], Int) - -- ^ (result kind, typechecked args, untypechecked args, n) -tcInferArgs fun fun_kind mb_kind_info args - = do { (res_kind, args', leftovers, n) - <- tc_infer_args typeLevelMode fun fun_kind mb_kind_info args 1 + -> TcM (TCvSubst, [TyBinder], [TcType], [LHsType Name], Int) + -- ^ (instantiating subst, un-insted leftover binders, + -- typechecked args, untypechecked args, n) +tcInferArgs fun binders mb_kind_info args + = do { (subst, leftover_binders, args', leftovers, n) + <- tc_infer_args typeLevelMode fun binders mb_kind_info args 1 -- now, we need to instantiate any remaining invisible arguments - ; let (invis_bndrs, really_res_kind) = splitPiTysInvisible res_kind - ; (subst, invis_args) - <- tcInstBindersX emptyTCvSubst mb_kind_info invis_bndrs - ; return ( substTy subst really_res_kind + ; let (invis_bndrs, other_binders) = span isInvisibleBinder leftover_binders + ; (subst', invis_args) + <- tcInstBindersX subst mb_kind_info invis_bndrs + ; return ( subst' + , other_binders , args' `chkAppend` invis_args , leftovers, n ) } @@ -733,48 +736,40 @@ tcInferArgs fun fun_kind mb_kind_info args tc_infer_args :: Outputable fun => TcTyMode -> fun -- ^ the function - -> TcKind -- ^ function kind (zonked) + -> [TyBinder] -- ^ function kind's binders (zonked) -> Maybe (VarEnv Kind) -- ^ possibly, kind info (see above) -> [LHsType Name] -- ^ args -> Int -- ^ number to start arg counter at - -> TcM (TcKind, [TcType], [LHsType Name], Int) -tc_infer_args mode orig_ty ki mb_kind_info orig_args n0 - = do { traceTc "tcInferApps" (ppr ki $$ ppr orig_args) - ; go emptyTCvSubst ki orig_args n0 [] } + -> TcM (TCvSubst, [TyBinder], [TcType], [LHsType Name], Int) +tc_infer_args mode orig_ty binders mb_kind_info orig_args n0 + = do { traceTc "tcInferApps" (ppr binders $$ ppr orig_args) + ; go emptyTCvSubst binders orig_args n0 [] } where - go subst fun_kind [] n acc - = return ( substTyUnchecked subst fun_kind, reverse acc, [], n ) + go subst binders [] n acc + = return ( subst, binders, reverse acc, [], n ) -- when we call this when checking type family patterns, we really -- do want to instantiate all invisible arguments. During other -- typechecking, we don't. - go subst fun_kind all_args n acc - | Just fun_kind' <- coreView fun_kind - = go subst fun_kind' all_args n acc + go subst binders all_args n acc + | (inv_binders, other_binders) <- span isInvisibleBinder binders + , not (null inv_binders) + = do { (subst', args') <- tcInstBindersX subst mb_kind_info inv_binders + ; go subst' other_binders all_args n (reverse args' ++ acc) } - | Just tv <- getTyVar_maybe fun_kind - , Just fun_kind' <- lookupTyVar subst tv - = go subst fun_kind' all_args n acc - - | (inv_bndrs, res_k) <- splitPiTysInvisible fun_kind - , not (null inv_bndrs) - = do { (subst', args') <- tcInstBindersX subst mb_kind_info inv_bndrs - ; go subst' res_k all_args n (reverse args' ++ acc) } - - | Just (bndr, res_k) <- splitPiTy_maybe fun_kind - , arg:args <- all_args -- this actually has to succeed - = ASSERT( isVisibleBinder bndr ) - do { let mode' | isNamedBinder bndr = kindLevel mode - | otherwise = mode + go subst (binder:binders) (arg:args) n acc + = ASSERT( isVisibleBinder binder ) + do { let mode' | isNamedBinder binder = kindLevel mode + | otherwise = mode ; arg' <- addErrCtxt (funAppCtxt orig_ty arg n) $ - tc_lhs_type mode' arg (substTyUnchecked subst $ binderType bndr) - ; let subst' = case binderVar_maybe bndr of + tc_lhs_type mode' arg (substTyUnchecked subst $ binderType binder) + ; let subst' = case binderVar_maybe binder of Just tv -> extendTvSubst subst tv arg' Nothing -> subst - ; go subst' res_k args (n+1) (arg' : acc) } + ; go subst' binders args (n+1) (arg' : acc) } - | otherwise - = return (substTy subst fun_kind, reverse acc, all_args, n) + go subst [] all_args n acc + = return (subst, [], reverse acc, all_args, n) -- | Applies a type to a list of arguments. Always consumes all the -- arguments. @@ -789,13 +784,13 @@ tcInferApps mode orig_ty ty ki args = go ty ki args 1 where go fun fun_kind [] _ = return (fun, fun_kind) go fun fun_kind args n - | Just fun_kind' <- coreView fun_kind - = go fun fun_kind' args n - - | isPiTy fun_kind - = do { (res_kind, args', leftover_args, n') - <- tc_infer_args mode orig_ty fun_kind Nothing args n - ; go (mkNakedAppTys fun args') res_kind leftover_args n' } + | let (binders, res_kind) = splitPiTys fun_kind + , not (null binders) + = do { (subst, leftover_binders, args', leftover_args, n') + <- tc_infer_args mode orig_ty binders Nothing args n + ; let fun_kind' = substTyUnchecked subst $ + mkForAllTys leftover_binders res_kind + ; go (mkNakedAppTys fun args') fun_kind' leftover_args n' } go fun fun_kind all_args@(arg:args) n = do { (co, arg_k, res_k) <- matchExpectedFunKind (length all_args) @@ -805,110 +800,6 @@ tcInferApps mode orig_ty ty ki args = go ty ki args 1 ; go (mkNakedAppTy (fun `mkNakedCastTy` co) arg') res_k args (n+1) } ---------------------------- --- | This is used to instantiate binders when type-checking *types* only. --- Precondition: all binders are invisible. See also Note [Bidirectional type checking] -tcInstBinders :: [TyBinder] -> TcM (TCvSubst, [TcType]) -tcInstBinders = tcInstBindersX emptyTCvSubst Nothing - --- | This is used to instantiate binders when type-checking *types* only. --- Precondition: all binders are invisible. --- The @VarEnv Kind@ gives some known instantiations. --- See also Note [Bidirectional type checking] -tcInstBindersX :: TCvSubst -> Maybe (VarEnv Kind) - -> [TyBinder] -> TcM (TCvSubst, [TcType]) -tcInstBindersX subst mb_kind_info bndrs - = do { (subst, args) <- mapAccumLM (tcInstBinderX mb_kind_info) subst bndrs - ; traceTc "instantiating implicit dependent vars:" - (vcat $ zipWith (\bndr arg -> ppr bndr <+> text ":=" <+> ppr arg) - bndrs args) - ; return (subst, args) } - --- | Used only in *types* -tcInstBinderX :: Maybe (VarEnv Kind) - -> TCvSubst -> TyBinder -> TcM (TCvSubst, TcType) -tcInstBinderX mb_kind_info subst binder - | Just tv <- binderVar_maybe binder - = case lookup_tv tv of - Just ki -> return (extendTvSubstAndInScope subst tv ki, ki) - Nothing -> do { (subst', tv') <- newMetaTyVarX subst tv - ; return (subst', mkTyVarTy tv') } - - -- This is the *only* constraint currently handled in types. - | Just (mk, role, k1, k2) <- get_pred_tys_maybe substed_ty - = do { let origin = TypeEqOrigin { uo_actual = k1 - , uo_expected = mkCheckExpType k2 - , uo_thing = Nothing } - ; co <- case role of - Nominal -> unifyKind noThing k1 k2 - Representational -> emitWantedEq origin KindLevel role k1 k2 - Phantom -> pprPanic "tcInstBinderX Phantom" (ppr binder) - ; arg' <- mk co k1 k2 - ; return (subst, arg') } - - | otherwise - = do { let (env, tidy_ty) = tidyOpenType emptyTidyEnv substed_ty - ; addErrTcM (env, text "Illegal constraint in a type:" <+> ppr tidy_ty) - - -- just invent a new variable so that we can continue - ; u <- newUnique - ; let name = mkSysTvName u (fsLit "dict") - ; return (subst, mkTyVarTy $ mkTyVar name substed_ty) } - - where - substed_ty = substTy subst (binderType binder) - - lookup_tv tv = do { env <- mb_kind_info -- `Maybe` monad - ; lookupVarEnv env tv } - - -- handle boxed equality constraints, because it's so easy - get_pred_tys_maybe ty - | Just (r, k1, k2) <- getEqPredTys_maybe ty - = Just (\co _ _ -> return $ mkCoercionTy co, r, k1, k2) - | Just (tc, [_, _, k1, k2]) <- splitTyConApp_maybe ty - = if | tc `hasKey` heqTyConKey - -> Just (mkHEqBoxTy, Nominal, k1, k2) - | otherwise - -> Nothing - | Just (tc, [_, k1, k2]) <- splitTyConApp_maybe ty - = if | tc `hasKey` eqTyConKey - -> Just (mkEqBoxTy, Nominal, k1, k2) - | tc `hasKey` coercibleTyConKey - -> Just (mkCoercibleBoxTy, Representational, k1, k2) - | otherwise - -> Nothing - | otherwise - = Nothing - -------------------------------- --- | This takes @a ~# b@ and returns @a ~~ b@. -mkHEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type --- monadic just for convenience with mkEqBoxTy -mkHEqBoxTy co ty1 ty2 - = return $ - mkTyConApp (promoteDataCon heqDataCon) [k1, k2, ty1, ty2, mkCoercionTy co] - where k1 = typeKind ty1 - k2 = typeKind ty2 - --- | This takes @a ~# b@ and returns @a ~ b@. -mkEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type -mkEqBoxTy co ty1 ty2 - = do { eq_tc <- tcLookupTyCon eqTyConName - ; let [datacon] = tyConDataCons eq_tc - ; hetero <- mkHEqBoxTy co ty1 ty2 - ; return $ mkTyConApp (promoteDataCon datacon) [k, ty1, ty2, hetero] } - where k = typeKind ty1 - --- | This takes @a ~R# b@ and returns @Coercible a b@. -mkCoercibleBoxTy :: TcCoercion -> Type -> Type -> TcM Type --- monadic just for convenience with mkEqBoxTy -mkCoercibleBoxTy co ty1 ty2 - = do { return $ - mkTyConApp (promoteDataCon coercibleDataCon) - [k, ty1, ty2, mkCoercionTy co] } - where k = typeKind ty1 - - -------------------------- checkExpectedKind :: TcType -- the type whose kind we're checking -> TcKind -- the known kind of that type, k @@ -1283,7 +1174,8 @@ kcHsTyVarBndrs :: Bool -- ^ True <=> the decl being checked has a CUSK -> ([TyVar] -> [TyVar] -> TcM (Kind, r)) -- ^ the result kind, possibly with other info -- ^ args are implicit vars, explicit vars - -> TcM (Kind, r) -- ^ The full kind of the thing being declared, + -> TcM ([TcTyBinder], TcKind, r) + -- ^ The full kind of the thing being declared, -- with the other info kcHsTyVarBndrs cusk (HsQTvs { hsq_implicit = kv_ns , hsq_explicit = hs_tvs }) thing_inside @@ -1293,9 +1185,9 @@ kcHsTyVarBndrs cusk (HsQTvs { hsq_implicit = kv_ns -- the names must line up in splitTelescopeTvs else zipWithM newSigTyVar kv_ns meta_kvs ; tcExtendTyVarEnv2 (kv_ns `zip` kvs) $ - do { (full_kind, _, stuff) <- bind_telescope hs_tvs (thing_inside kvs) + do { (binders, res_kind, _, stuff) <- bind_telescope hs_tvs (thing_inside kvs) ; let qkvs = filter (not . isMetaTyVar) $ - tyCoVarsOfTypeWellScoped full_kind + tyCoVarsOfTypeWellScoped (mkForAllTys binders res_kind) -- these have to be the vars made with new_skolem_tv -- above. Thus, they are known to the user and should -- be Specified, not Invisible, when kind-generalizing @@ -1303,28 +1195,28 @@ kcHsTyVarBndrs cusk (HsQTvs { hsq_implicit = kv_ns -- the free non-meta variables in the returned kind will -- contain both *mentioned* kind vars and *unmentioned* kind -- vars (See case (1) under Note [Typechecking telescopes]) - gen_kind = if cusk - then mkSpecForAllTys qkvs $ full_kind - else full_kind - ; return (gen_kind, stuff) } } + all_binders = if cusk + then map (mkNamedBinder Specified) qkvs ++ binders + else binders + ; return (all_binders, res_kind, stuff) } } where -- there may be dependency between the explicit "ty" vars. So, we have - -- to handle them one at a time. We also need to build up a full kind - -- here, because this is the place we know whether to use a FunTy or a - -- ForAllTy. We prefer using an anonymous binder over a trivial named + -- to handle them one at a time. We also produce the TyBinders here, + -- because this is the place we know whether to use Anon or Named. + -- We prefer using an anonymous binder over a trivial named -- binder. If a user wants a trivial named one, use an explicit kind -- signature. bind_telescope :: [LHsTyVarBndr Name] -> ([TyVar] -> TcM (Kind, r)) - -> TcM (Kind, VarSet, r) + -> TcM ([TcTyBinder], TcKind, VarSet, r) bind_telescope [] thing = do { (res_kind, stuff) <- thing [] - ; return (res_kind, tyCoVarsOfType res_kind, stuff) } + ; return ([], res_kind, tyCoVarsOfType res_kind, stuff) } bind_telescope (L _ hs_tv : hs_tvs) thing = do { tv_pair@(tv, _) <- kc_hs_tv hs_tv - ; (res_kind, fvs, stuff) <- bind_unless_scoped tv_pair $ - bind_telescope hs_tvs $ \tvs -> - thing (tv:tvs) + ; (binders, res_kind, fvs, stuff) <- bind_unless_scoped tv_pair $ + bind_telescope hs_tvs $ \tvs -> + thing (tv:tvs) -- we must be *lazy* in res_kind and fvs (assuming that the -- caller of kcHsTyVarBndrs is, too), as sometimes these hold -- panics. See kcConDecl. @@ -1337,7 +1229,7 @@ kcHsTyVarBndrs cusk (HsQTvs { hsq_implicit = kv_ns | otherwise = (mkAnonBinder k, fvs `unionVarSet` k_fvs) - ; return ( mkForAllTy bndr res_kind, fvs', stuff ) } + ; return (bndr : binders, res_kind, fvs', stuff ) } -- | Bind the tyvar in the env't unless the bool is True bind_unless_scoped :: (TcTyVar, Bool) -> TcM a -> TcM a @@ -1650,30 +1542,28 @@ are kind vars the didn't link up in splitTelescopeTvs. -- Extend the env with bindings for the tyvars, taken from -- the kind of the tycon/class. Give it to the thing inside, and -- check the result kind matches -kcLookupKind :: Name -> TcM Kind +kcLookupKind :: Name -> TcM ([TyBinder], Kind) kcLookupKind nm = do { tc_ty_thing <- tcLookup nm ; case tc_ty_thing of - ATcTyCon tc -> return (tyConKind tc) - AGlobal (ATyCon tc) -> return (tyConKind tc) + ATcTyCon tc -> return (tyConBinders tc, tyConResKind tc) + AGlobal (ATyCon tc) -> return (tyConBinders tc, tyConResKind tc) _ -> pprPanic "kcLookupKind" (ppr tc_ty_thing) } -- See Note [Typechecking telescopes] -splitTelescopeTvs :: Kind -- of the head of the telescope +splitTelescopeTvs :: [TyBinder] -- telescope binders -> LHsQTyVars Name -> ( [TyVar] -- scoped type variables , NameSet -- ungeneralized implicit variables (case 2a) , [TyVar] -- implicit type variables (cases 1 & 2) , [TyVar] -- explicit type variables (cases 3 & 4) - , [(LHsKind Name, Kind)] -- see Note [Tiresome kind matching] - , Kind ) -- result kind -splitTelescopeTvs kind tvbs@(HsQTvs { hsq_implicit = hs_kvs - , hsq_explicit = hs_tvs }) - = let (bndrs, inner_ki) = splitPiTys kind - (scoped_tvs, non_cusk_imp_names, imp_tvs, exp_tvs, kind_matches, mk_kind) + , [(LHsKind Name, Kind)] ) -- see Note [Tiresome kind matching] +splitTelescopeTvs bndrs tvbs@(HsQTvs { hsq_implicit = hs_kvs + , hsq_explicit = hs_tvs }) + = let (scoped_tvs, non_cusk_imp_names, imp_tvs, exp_tvs, kind_matches) = mk_tvs [] [] bndrs (mkNameSet hs_kvs) hs_tvs in - (scoped_tvs, non_cusk_imp_names, imp_tvs, exp_tvs, kind_matches, mk_kind inner_ki) + (scoped_tvs, non_cusk_imp_names, imp_tvs, exp_tvs, kind_matches) where mk_tvs :: [TyVar] -- scoped tv accum (reversed) -> [TyVar] -- implicit tv accum (reversed) @@ -1684,8 +1574,7 @@ splitTelescopeTvs kind tvbs@(HsQTvs { hsq_implicit = hs_kvs , NameSet -- Case 2a names , [TyVar] -- implicit tyvars , [TyVar] -- explicit tyvars - , [(LHsKind Name, Kind)] -- tiresome kind matches - , Type -> Type ) -- a function to create the result k + , [(LHsKind Name, Kind)] ) -- tiresome kind matches mk_tvs scoped_tv_acc imp_tv_acc (bndr : bndrs) all_hs_kvs all_hs_tvs | Just tv <- binderVar_maybe bndr , isInvisibleBinder bndr @@ -1703,9 +1592,9 @@ splitTelescopeTvs kind tvbs@(HsQTvs { hsq_implicit = hs_kvs -- a non-CUSK. The kinds *aren't* generalized, so we won't see them -- here. mk_tvs scoped_tv_acc imp_tv_acc all_bndrs all_hs_kvs all_hs_tvs - = let (scoped, exp_tvs, kind_matches, mk_kind) + = let (scoped, exp_tvs, kind_matches) = mk_tvs2 scoped_tv_acc [] [] all_bndrs all_hs_tvs in - (scoped, all_hs_kvs, reverse imp_tv_acc, exp_tvs, kind_matches, mk_kind) + (scoped, all_hs_kvs, reverse imp_tv_acc, exp_tvs, kind_matches) -- no more Case (1) or (2) -- This can't handle Case (1) or Case (2) from [Typechecking telescopes] @@ -1716,8 +1605,7 @@ splitTelescopeTvs kind tvbs@(HsQTvs { hsq_implicit = hs_kvs -> [LHsTyVarBndr Name] -> ( [TyVar] , [TyVar] -- explicit tvs only - , [(LHsKind Name, Kind)] -- tiresome kind matches - , Type -> Type ) + , [(LHsKind Name, Kind)] ) -- tiresome kind matches mk_tvs2 scoped_tv_acc exp_tv_acc kind_match_acc (bndr : bndrs) (hs_tv : hs_tvs) | Just tv <- binderVar_maybe bndr = ASSERT2( isVisibleBinder bndr, err_doc ) @@ -1733,7 +1621,6 @@ splitTelescopeTvs kind tvbs@(HsQTvs { hsq_implicit = hs_kvs where err_doc = vcat [ ppr (bndr : bndrs) , ppr (hs_tv : hs_tvs) - , ppr kind , ppr tvbs ] kind_match_acc' = case hs_tv of @@ -1741,11 +1628,10 @@ splitTelescopeTvs kind tvbs@(HsQTvs { hsq_implicit = hs_kvs L _ (KindedTyVar _ hs_kind) -> (hs_kind, kind) : kind_match_acc where kind = binderType bndr - mk_tvs2 scoped_tv_acc exp_tv_acc kind_match_acc all_bndrs [] -- All done! + mk_tvs2 scoped_tv_acc exp_tv_acc kind_match_acc [] [] -- All done! = ( reverse scoped_tv_acc , reverse exp_tv_acc - , kind_match_acc -- no need to reverse; it's not ordered - , mkForAllTys all_bndrs ) + , kind_match_acc ) -- no need to reverse; it's not ordered mk_tvs2 _ _ _ all_bndrs all_hs_tvs = pprPanic "splitTelescopeTvs 2" (vcat [ ppr all_bndrs @@ -1762,18 +1648,18 @@ kcTyClTyVars :: Name -- ^ of the tycon -> LHsQTyVars Name -> TcM a -> TcM a kcTyClTyVars tycon hs_tvs thing_inside - = do { kind <- kcLookupKind tycon - ; let (scoped_tvs, non_cusk_kv_name_set, all_kvs, all_tvs, _, res_k) - = splitTelescopeTvs kind hs_tvs + = do { (binders, res_kind) <- kcLookupKind tycon + ; let (scoped_tvs, non_cusk_kv_name_set, all_kvs, all_tvs, _) + = splitTelescopeTvs binders hs_tvs ; traceTc "kcTyClTyVars splitTelescopeTvs:" (vcat [ text "Tycon:" <+> ppr tycon - , text "Kind:" <+> ppr kind + , text "Binders:" <+> ppr binders + , text "res_kind:" <+> ppr res_kind , text "hs_tvs:" <+> ppr hs_tvs , text "scoped tvs:" <+> pprWithCommas pprTvBndr scoped_tvs , text "implicit tvs:" <+> pprWithCommas pprTvBndr all_kvs , text "explicit tvs:" <+> pprWithCommas pprTvBndr all_tvs - , text "non-CUSK kvs:" <+> ppr non_cusk_kv_name_set - , text "res_k:" <+> ppr res_k] ) + , text "non-CUSK kvs:" <+> ppr non_cusk_kv_name_set ] ) -- need to look up the non-cusk kvs in order to get their -- kinds right, in case the kinds were informed by @@ -1799,7 +1685,7 @@ kcTyClTyVars tycon hs_tvs thing_inside thing_inside } tcTyClTyVars :: Name -> LHsQTyVars Name -- LHS of the type or class decl - -> ([TyVar] -> [TyVar] -> Kind -> Kind -> TcM a) -> TcM a + -> ([TyVar] -> [TyVar] -> [TyBinder] -> Kind -> TcM a) -> TcM a -- ^ Used for the type variables of a type or class decl -- on the second full pass (type-checking/desugaring) in TcTyClDecls. -- This is *not* used in the initial-kind run, nor in the "kind-checking" pass. @@ -1807,7 +1693,7 @@ tcTyClTyVars :: Name -> LHsQTyVars Name -- LHS of the type or class decl -- (tcTyClTyVars T [a,b] thing_inside) -- where T : forall k1 k2 (a:k1 -> *) (b:k1). k2 -> * -- calls thing_inside with arguments --- [k1,k2] [a,b] (forall (k1:*) (k2:*) (a:k1 -> *) (b:k1). k2 -> *) (k2 -> *) +-- [k1,k2] [a,b] [k1:*, k2:*, a:k1 -> *, b:k1] (k2 -> *) -- having also extended the type environment with bindings -- for k1,k2,a,b -- @@ -1816,27 +1702,27 @@ tcTyClTyVars :: Name -> LHsQTyVars Name -- LHS of the type or class decl -- The LHsTyVarBndrs is always user-written, and the full, generalised -- kind of the tycon is available in the local env. tcTyClTyVars tycon hs_tvs thing_inside - = do { kind <- kcLookupKind tycon + = do { (binders, res_kind) <- kcLookupKind tycon ; let ( scoped_tvs, float_kv_name_set, all_kvs - , all_tvs, kind_matches, res_k ) - = splitTelescopeTvs kind hs_tvs + , all_tvs, kind_matches ) + = splitTelescopeTvs binders hs_tvs ; traceTc "tcTyClTyVars splitTelescopeTvs:" (vcat [ text "Tycon:" <+> ppr tycon - , text "Kind:" <+> ppr kind + , text "Binders:" <+> ppr binders + , text "res_kind:" <+> ppr res_kind , text "hs_tvs:" <+> ppr hs_tvs , text "scoped tvs:" <+> pprWithCommas pprTvBndr scoped_tvs , text "implicit tvs:" <+> pprWithCommas pprTvBndr all_kvs , text "explicit tvs:" <+> pprWithCommas pprTvBndr all_tvs , text "floating kvs:" <+> ppr float_kv_name_set - , text "Tiresome kind matches:" <+> ppr kind_matches - , text "res_k:" <+> ppr res_k] ) + , text "Tiresome kind matches:" <+> ppr kind_matches ] ) ; float_kvs <- deal_with_float_kvs float_kv_name_set kind_matches scoped_tvs all_tvs ; tcExtendTyVarEnv (float_kvs ++ scoped_tvs) $ -- the float_kvs are already in the all_kvs - thing_inside all_kvs all_tvs kind res_k } + thing_inside all_kvs all_tvs binders res_kind } where -- See Note [Free-floating kind vars] deal_with_float_kvs float_kv_name_set kind_matches scoped_tvs all_tvs @@ -1879,13 +1765,15 @@ tcTyClTyVars tycon hs_tvs thing_inside 2 (pprTvBndrs all_tvs) ] ----------------------------------- -tcDataKindSig :: Kind -> TcM [TyVar] +tcDataKindSig :: Kind -> TcM ([TyVar], [TyBinder], Kind) -- GADT decls can have a (perhaps partial) kind signature -- e.g. data T :: * -> * -> * where ... -- This function makes up suitable (kinded) type variables for -- the argument kinds, and checks that the result kind is indeed *. -- We use it also to make up argument type variables for for data instances. -- Never emits constraints. +-- Returns the new TyVars, the extracted TyBinders, and the new, reduced +-- result kind (which should always be Type or a synonym thereof) tcDataKindSig kind = do { checkTc (isLiftedTypeKind res_kind) (badKindSig kind) ; span <- getSrcSpanM @@ -1897,8 +1785,9 @@ tcDataKindSig kind , isNothing (lookupLocalRdrOcc rdr_env occ) ] -- Note [Avoid name clashes for associated data types] - ; return [ mk_tv span uniq occ kind - | ((kind, occ), uniq) <- arg_kinds `zip` occs `zip` uniqs ] } + ; return ( [ mk_tv span uniq occ kind + | ((kind, occ), uniq) <- arg_kinds `zip` occs `zip` uniqs ] + , bndrs, res_kind ) } where (bndrs, res_kind) = splitPiTys kind arg_kinds = map binderType bndrs @@ -2121,8 +2010,8 @@ in-scope variables that it should not unify with, but it's fiddly. -- | Produce an 'TcKind' suitable for a checking a type that can be * or #. ekOpen :: TcM TcKind -ekOpen = do { lev <- newFlexiTyVarTy levityTy - ; return (tYPE lev) } +ekOpen = do { rr <- newFlexiTyVarTy runtimeRepTy + ; return (tYPE rr) } unifyKinds :: [(TcType, TcKind)] -> TcM ([TcType], TcKind) unifyKinds act_kinds diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index 82c66cc953..460089e457 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -684,12 +684,13 @@ tcDataFamInstDecl mb_clsinfo axiom_name eta_tvs [] fam_tc eta_pats (mkTyConApp rep_tc (mkTyVarTys eta_tvs)) parent = DataFamInstTyCon axiom fam_tc pats' - rep_tc_kind = mkPiTypesPreferFunTy full_tvs liftedTypeKind + ty_binders = mkTyBindersPreferAnon full_tvs liftedTypeKind + -- NB: Use the full_tvs from the pats. See bullet toward -- the end of Note [Data type families] in TyCon rep_tc = mkAlgTyCon rep_tc_name - rep_tc_kind + ty_binders liftedTypeKind full_tvs (map (const Nominal) full_tvs) (fmap unLoc cType) stupid_theta @@ -1275,7 +1276,7 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys error_rhs dflags = L inst_loc $ HsApp error_fun (error_msg dflags) error_fun = L inst_loc $ wrapId (mkWpTyApps - [ getLevity "tcInstanceMethods.tc_default" meth_tau + [ getRuntimeRep "tcInstanceMethods.tc_default" meth_tau , meth_tau]) nO_METHOD_BINDING_ERROR_ID error_msg dflags = L inst_loc (HsLit (HsStringPrim "" diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs index b7a96d9f63..90f7243b25 100644 --- a/compiler/typecheck/TcInteract.hs +++ b/compiler/typecheck/TcInteract.hs @@ -2027,7 +2027,7 @@ onlyNamedBndrsApplied tc ks = all isNamedBinder used_bndrs && not (any isNamedBinder leftover_bndrs) where - (bndrs, _) = splitPiTys (tyConKind tc) + bndrs = tyConBinders tc (used_bndrs, leftover_bndrs) = splitAtList ks bndrs doTyApp :: Class -> Type -> Type -> KindOrType -> TcS LookupInstResult diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs index d058107cc9..e8c120ddbb 100644 --- a/compiler/typecheck/TcMType.hs +++ b/compiler/typecheck/TcMType.hs @@ -70,7 +70,7 @@ module TcMType ( zonkTcTyVar, zonkTcTyVars, zonkTyCoVarsAndFV, zonkTcTypeAndFV, zonkQuantifiedTyVar, zonkQuantifiedTyVarOrType, quantifyTyVars, defaultKindVar, - zonkTcTyCoVarBndr, zonkTcType, zonkTcTypes, zonkCo, + zonkTcTyCoVarBndr, zonkTcTyBinder, zonkTcType, zonkTcTypes, zonkCo, zonkTyCoVarKind, zonkTcTypeMapper, zonkEvVar, zonkWC, zonkSimples, zonkId, zonkCt, zonkSkolemInfo, @@ -330,10 +330,10 @@ test gadt/gadt-escape1. -- | Make an 'ExpType' suitable for inferring a type of kind * or #. newOpenInferExpType :: TcM ExpType newOpenInferExpType - = do { lev <- newFlexiTyVarTy levityTy + = do { rr <- newFlexiTyVarTy runtimeRepTy ; u <- newUnique ; tclvl <- getTcLevel - ; let ki = tYPE lev + ; let ki = tYPE rr ; traceTc "newOpenInferExpType" (ppr u <+> dcolon <+> ppr ki) ; ref <- newMutVar Nothing ; return (Infer u tclvl ki ref) } @@ -549,7 +549,6 @@ newFskTyVar fam_ty = do { uniq <- newUnique ; let name = mkSysTvName uniq (fsLit "fsk") ; return (mkTcTyVar name (typeKind fam_ty) (FlatSkol fam_ty)) } - {- Note [Kind substitution when instantiating] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -754,8 +753,8 @@ newFlexiTyVarTys n kind = mapM newFlexiTyVarTy (nOfThem n kind) -- | Create a tyvar that can be a lifted or unlifted type. newOpenFlexiTyVarTy :: TcM TcType newOpenFlexiTyVarTy - = do { lev <- newFlexiTyVarTy levityTy - ; newFlexiTyVarTy (tYPE lev) } + = do { rr <- newFlexiTyVarTy runtimeRepTy + ; newFlexiTyVarTy (tYPE rr) } newMetaSigTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) newMetaSigTyVars = mapAccumLM newMetaSigTyVarX emptyTCvSubst @@ -904,15 +903,15 @@ zonkQuantifiedTyVar :: TcTyVar -> TcM (Maybe TcTyVar) -- -- This returns a tyvar if it should be quantified over; otherwise, -- it returns Nothing. Nothing is --- returned only if zonkQuantifiedTyVar is passed a Levity meta-tyvar, --- in order to default to Lifted. +-- returned only if zonkQuantifiedTyVar is passed a RuntimeRep meta-tyvar, +-- in order to default to PtrRepLifted. zonkQuantifiedTyVar tv = left_only `liftM` zonkQuantifiedTyVarOrType tv where left_only :: Either a b -> Maybe a left_only (Left x) = Just x left_only (Right _) = Nothing -- | Like zonkQuantifiedTyVar, but if zonking reveals that the tyvar --- should become a type (when defaulting a levity var to Lifted), it +-- should become a type (when defaulting a RuntimeRep var to PtrRepLifted), it -- returns the type instead. zonkQuantifiedTyVarOrType :: TcTyVar -> TcM (Either TcTyVar TcType) zonkQuantifiedTyVarOrType tv @@ -931,19 +930,19 @@ zonkQuantifiedTyVarOrType tv Flexi -> return () Indirect ty -> WARN( True, ppr tv $$ ppr ty ) return () - if isLevityVar tv - then do { writeMetaTyVar tv liftedDataConTy - ; return (Right liftedDataConTy) } + if isRuntimeRepVar tv + then do { writeMetaTyVar tv ptrRepLiftedTy + ; return (Right ptrRepLiftedTy) } else Left `liftM` skolemiseUnboundMetaTyVar tv vanillaSkolemTv _other -> pprPanic "zonkQuantifiedTyVar" (ppr tv) -- FlatSkol, RuntimeUnk -- | Take an (unconstrained) meta tyvar and default it. Works only for --- kind vars (of type BOX) and levity vars (of type Levity). +-- kind vars (of type *) and RuntimeRep vars (of type RuntimeRep). defaultKindVar :: TcTyVar -> TcM Kind defaultKindVar kv | ASSERT( isMetaTyVar kv ) - isLevityVar kv - = writeMetaTyVar kv liftedDataConTy >> return liftedDataConTy + isRuntimeRepVar kv + = writeMetaTyVar kv ptrRepLiftedTy >> return ptrRepLiftedTy | otherwise = writeMetaTyVar kv liftedTypeKind >> return liftedTypeKind @@ -1283,6 +1282,11 @@ zonkTcTyCoVarBndr tyvar = ASSERT2( isImmutableTyVar tyvar || (not $ isTyVar tyvar), ppr tyvar ) do updateTyVarKindM zonkTcType tyvar +-- | Zonk a TyBinder +zonkTcTyBinder :: TcTyBinder -> TcM TcTyBinder +zonkTcTyBinder (Anon ty) = Anon <$> zonkTcType ty +zonkTcTyBinder (Named tv vis) = Named <$> zonkTcTyCoVarBndr tv <*> pure vis + zonkTcTyVar :: TcTyVar -> TcM TcType -- Simply look through all Flexis zonkTcTyVar tv diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index 4d1d09a32f..bd769bfe29 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -458,8 +458,8 @@ tc_pat penv (TuplePat pats boxity _) pat_ty thing_inside tc = tupleTyCon boxity arity ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) penv pat_ty - -- Unboxed tuples have levity vars, which we discard: - -- See Note [Unboxed tuple levity vars] in TyCon + -- Unboxed tuples have RuntimeRep vars, which we discard: + -- See Note [Unboxed tuple RuntimeRep vars] in TyCon ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys Boxed -> arg_tys ; (pats', res) <- tc_lpats penv pats (map mkCheckExpType con_arg_tys) diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index 1e833242cb..b627cd4a2e 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -19,7 +19,7 @@ import TcRnMonad import TcEnv import TcMType import TysPrim -import TysWiredIn ( levityTy ) +import TysWiredIn ( runtimeRepTy ) import Name import SrcLoc import PatSyn @@ -463,13 +463,13 @@ tcPatSynMatcher has_sig (L loc name) lpat (univ_tvs, req_theta, req_ev_binds, req_dicts) (ex_tvs, ex_tys, prov_theta, prov_dicts) (args, arg_tys) pat_ty - = do { lev_uniq <- newUnique - ; tv_uniq <- newUnique - ; let lev_name = mkInternalName lev_uniq (mkTyVarOcc "rlev") loc + = do { rr_uniq <- newUnique + ; tv_uniq <- newUnique + ; let rr_name = mkInternalName rr_uniq (mkTyVarOcc "rep") loc tv_name = mkInternalName tv_uniq (mkTyVarOcc "r") loc - lev_tv = mkTcTyVar lev_name levityTy (SkolemTv False) - lev = mkTyVarTy lev_tv - res_tv = mkTcTyVar tv_name (tYPE lev) (SkolemTv False) + rr_tv = mkTcTyVar rr_name runtimeRepTy (SkolemTv False) + rr = mkTyVarTy rr_tv + res_tv = mkTcTyVar tv_name (tYPE rr) (SkolemTv False) is_unlifted = null args && null prov_dicts res_ty = mkTyVarTy res_tv (cont_args, cont_arg_tys) @@ -487,7 +487,7 @@ tcPatSynMatcher has_sig (L loc name) lpat ; fail <- newSysLocalId (fsLit "fail") fail_ty ; let matcher_tau = mkFunTys [pat_ty, cont_ty, fail_ty] res_ty - matcher_sigma = mkInvSigmaTy (lev_tv:res_tv:univ_tvs) req_theta matcher_tau + matcher_sigma = mkInvSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau matcher_id = mkExportedVanillaId matcher_name matcher_sigma -- See Note [Exported LocalIds] in Id @@ -517,7 +517,7 @@ tcPatSynMatcher has_sig (L loc name) lpat , mg_res_ty = res_ty , mg_origin = Generated } - match = mkMatch [] (mkHsLams (lev_tv:res_tv:univ_tvs) req_dicts body') + match = mkMatch [] (mkHsLams (rr_tv:res_tv:univ_tvs) req_dicts body') (noLoc EmptyLocalBinds) mg = MG{ mg_alts = L (getLoc match) [match] , mg_arg_tys = [] diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index fdc6e5e638..a2a04e9bde 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -1915,7 +1915,7 @@ tcGhciStmts stmts (noLoc $ ExplicitList unitTy Nothing (map mk_item ids)) ; mk_item id = let ty_args = [idType id, unitTy] in nlHsApp (nlHsTyApp unsafeCoerceId - (map (getLevity "tcGhciStmts") ty_args ++ ty_args)) + (map (getRuntimeRep "tcGhciStmts") ty_args ++ ty_args)) (nlHsVar id) ; stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)] } ; diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs index 053c53b86a..4e5cceb07a 100644 --- a/compiler/typecheck/TcSMonad.hs +++ b/compiler/typecheck/TcSMonad.hs @@ -929,9 +929,9 @@ Note [Flavours with roles] ~~~~~~~~~~~~~~~~~~~~~~~~~~ The system described in Note [inert_eqs: the inert equalities] discusses an abstract -set of flavours. In GHC, flavours have three components: the flavour proper, -taken from {Wanted, Derived, Given}; the equality relation (often called -role), taken from {NomEq, ReprEq}; and the levity, taken from {Lifted, Unlifted}. +set of flavours. In GHC, flavours have two components: the flavour proper, +taken from {Wanted, Derived, Given} and the equality relation (often called +role), taken from {NomEq, ReprEq}. When substituting w.r.t. the inert set, as described in Note [inert_eqs: the inert equalities], we must be careful to respect all components of a flavour. diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs index be0735816b..a19ceaa39d 100644 --- a/compiler/typecheck/TcSimplify.hs +++ b/compiler/typecheck/TcSimplify.hs @@ -37,7 +37,7 @@ import TcSMonad as TcS import TcType import TrieMap () -- DV: for now import Type -import TysWiredIn ( liftedDataConTy ) +import TysWiredIn ( ptrRepLiftedTy ) import Unify ( tcMatchTy ) import Util import Var @@ -1488,24 +1488,24 @@ promoteTyVarTcS tclvl tv | otherwise = return () --- | If the tyvar is a levity var, set it to Lifted. Returns whether or +-- | If the tyvar is a RuntimeRep var, set it to PtrRepLifted. Returns whether or -- not this happened. defaultTyVar :: TcTyVar -> TcM () -- Precondition: MetaTyVars only -- See Note [DefaultTyVar] defaultTyVar the_tv - | isLevityVar the_tv - = do { traceTc "defaultTyVar levity" (ppr the_tv) - ; writeMetaTyVar the_tv liftedDataConTy } + | isRuntimeRepVar the_tv + = do { traceTc "defaultTyVar RuntimeRep" (ppr the_tv) + ; writeMetaTyVar the_tv ptrRepLiftedTy } | otherwise = return () -- The common case -- | Like 'defaultTyVar', but in the TcS monad. defaultTyVarTcS :: TcTyVar -> TcS Bool defaultTyVarTcS the_tv - | isLevityVar the_tv - = do { traceTcS "defaultTyVarTcS levity" (ppr the_tv) - ; unifyTyVar the_tv liftedDataConTy + | isRuntimeRepVar the_tv + = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv) + ; unifyTyVar the_tv ptrRepLiftedTy ; return True } | otherwise = return False -- the common case @@ -1591,13 +1591,13 @@ There are two caveats: Note [DefaultTyVar] ~~~~~~~~~~~~~~~~~~~ defaultTyVar is used on any un-instantiated meta type variables to -default any levity variables to Lifted. This is important +default any RuntimeRep variables to PtrRepLifted. This is important to ensure that instance declarations match. For example consider instance Show (a->b) foo x = show (\_ -> True) -Then we'll get a constraint (Show (p ->q)) where p has kind ArgKind, +Then we'll get a constraint (Show (p ->q)) where p has kind (TYPE r), and that won't match the typeKind (*) in the instance decl. See tests tc217 and tc175. @@ -1607,7 +1607,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 levity variable to Lifted, but this seems unnecessarily indirect. +the RuntimeRep variable to PtrRepLifted, but this seems unnecessarily indirect. Note [Promote _and_ default when inferring] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 921da07d2d..ac2ad01864 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -1309,14 +1309,9 @@ reifyTyCon tc | isTypeFamilyTyCon tc = do { let tvs = tyConTyVars tc - kind = tyConKind tc + res_kind = tyConResKind tc resVar = famTcResVar tc - -- we need the *result kind* (see #8884) - (kvs, mono_kind) = splitForAllTys kind - -- tyConArity includes *kind* params - (_, res_kind) = splitFunTysN (tyConArity tc - length kvs) - mono_kind ; kind' <- reifyKind res_kind ; let (resultSig, injectivity) = case resVar of @@ -1351,13 +1346,8 @@ reifyTyCon tc | isDataFamilyTyCon tc = do { let tvs = tyConTyVars tc - kind = tyConKind tc + res_kind = tyConResKind tc - -- we need the *result kind* (see #8884) - (kvs, mono_kind) = splitForAllTys kind - -- tyConArity includes *kind* params - (_, res_kind) = splitFunTysN (tyConArity tc - length kvs) - mono_kind ; kind' <- fmap Just (reifyKind res_kind) ; tvs' <- reifyTyVars tvs (Just tc) @@ -1732,8 +1722,9 @@ reify_tc_app tc tys = do { tys' <- reifyTypes (filterOutInvisibleTypes tc tys) ; maybe_sig_t (mkThAppTs r_tc tys') } where - arity = tyConArity tc - tc_kind = tyConKind tc + arity = tyConArity tc + tc_binders = tyConBinders tc + tc_res_kind = tyConResKind tc r_tc | isTupleTyCon tc = if isPromotedDataCon tc then TH.PromotedTupleT arity @@ -1756,18 +1747,15 @@ reify_tc_app tc tys = return th_type needs_kind_sig - | Just result_ki <- peel_off_n_args tc_kind (length tys) - = not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType result_ki - | otherwise + | GT <- compareLength tys tc_binders + , tcIsTyVarTy tc_res_kind = True - - peel_off_n_args :: Kind -> Arity -> Maybe Kind - peel_off_n_args k 0 = Just k - peel_off_n_args k n - | Just (_, res_k) <- splitPiTy_maybe k - = peel_off_n_args res_k (n-1) | otherwise - = Nothing + = not $ + isEmptyVarSet $ + filterVarSet isTyVar $ + tyCoVarsOfType $ + mkForAllTys (dropList tys tc_binders) tc_res_kind reifyPred :: TyCoRep.PredType -> TcM TH.Pred reifyPred ty diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index e68efd09f9..6fee0124a3 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -126,8 +126,8 @@ tcTyClGroup tyclds = do { -- Step 1: kind-check this group and returns the final -- (possibly-polymorphic) kind of each TyCon and Class -- See Note [Kind checking for type and class decls] - names_w_poly_kinds <- kcTyClGroup tyclds - ; traceTc "tcTyAndCl generalized kinds" (ppr names_w_poly_kinds) + tc_tycons <- kcTyClGroup tyclds + ; traceTc "tcTyAndCl generalized kinds" (vcat (map ppr_tc_tycon tc_tycons)) -- Step 2: type-check all groups together, returning -- the final TyCons and Classes @@ -143,13 +143,12 @@ tcTyClGroup tyclds -- NB: if the decls mention any ill-staged data cons -- (see Note [Recusion and promoting data constructors]) -- we will have failed already in kcTyClGroup, so no worries here - ; tcExtendRecEnv (zipRecTyClss names_w_poly_kinds rec_tyclss) $ + ; tcExtendRecEnv (zipRecTyClss tc_tycons rec_tyclss) $ -- Also extend the local type envt with bindings giving -- the (polymorphic) kind of each knot-tied TyCon or Class -- See Note [Type checking recursive type and class declarations] - tcExtendKindEnv2 [ mkTcTyConPair name kind m_arity - | (name, kind, m_arity) <- names_w_poly_kinds ] $ + tcExtendKindEnv2 (map mkTcTyConPair tc_tycons) $ -- Kind and type check declarations for this group mapM (tcTyClDecl rec_flags) decls } @@ -169,8 +168,12 @@ tcTyClGroup tyclds -- they may be mentioned in interface files ; tcExtendTyConEnv tyclss $ tcAddImplicits tyclss } + where + ppr_tc_tycon tc = parens (sep [ ppr (tyConName tc) <> comma + , ppr (tyConBinders tc) <> comma + , ppr (tyConResKind tc) ]) -zipRecTyClss :: [(Name, Kind, Maybe Arity)] +zipRecTyClss :: [TcTyCon] -> [TyCon] -- Knot-tied -> [(Name,TyThing)] -- Build a name-TyThing mapping for the TyCons bound by decls @@ -178,8 +181,8 @@ zipRecTyClss :: [(Name, Kind, Maybe Arity)] -- The TyThings in the result list must have a visible ATyCon, -- because typechecking types (in, say, tcTyClDecl) looks at -- this outer constructor -zipRecTyClss kind_pairs rec_tycons - = [ (name, ATyCon (get name)) | (name, _kind, _m_arity) <- kind_pairs ] +zipRecTyClss tc_tycons rec_tycons + = [ (name, ATyCon (get name)) | tc_tycon <- tc_tycons, let name = getName tc_tycon ] where rec_tc_env :: NameEnv TyCon rec_tc_env = foldr add_tc emptyNameEnv rec_tycons @@ -260,7 +263,7 @@ See also Note [Kind checking recursive type and class declarations] -} -kcTyClGroup :: TyClGroup Name -> TcM [(Name,Kind,Maybe Arity)] +kcTyClGroup :: TyClGroup Name -> TcM [TcTyCon] -- Kind check this group, kind generalize, and return the resulting local env -- This bindds the TyCons and Classes of the group, but not the DataCons -- See Note [Kind checking for type and class decls] @@ -303,24 +306,29 @@ kcTyClGroup (TyClGroup { group_tyclds = decls }) ; return res } where - generalise :: TcTypeEnv -> Name -> TcM (Name, Kind, Maybe Arity) + generalise :: TcTypeEnv -> Name -> TcM TcTyCon -- For polymorphic things this is a no-op generalise kind_env name - = do { let (kc_kind, kc_unsat) = case lookupNameEnv kind_env name of - Just (ATcTyCon tc) -> ( tyConKind tc - , if mightBeUnsaturatedTyCon tc - then Nothing - else Just $ tyConArity tc ) - _ -> pprPanic "kcTyClGroup" (ppr name $$ ppr kind_env) - ; kvs <- kindGeneralize kc_kind - ; kc_kind' <- zonkTcTypeToType emptyZonkEnv kc_kind + = do { let tc = case lookupNameEnv kind_env name of + Just (ATcTyCon tc) -> tc + _ -> pprPanic "kcTyClGroup" (ppr name $$ ppr kind_env) + kc_binders = tyConBinders tc + kc_res_kind = tyConResKind tc + ; kvs <- kindGeneralize (mkForAllTys kc_binders kc_res_kind) + ; (kc_binders', kc_res_kind') <- zonkTcKindToKind kc_binders kc_res_kind -- Make sure kc_kind' has the final, zonked kind variables - ; traceTc "Generalise kind" (vcat [ ppr name, ppr kc_kind, ppr kvs, ppr kc_kind' ]) - ; return (name, mkInvForAllTys kvs kc_kind', kc_unsat) } + ; traceTc "Generalise kind" $ + vcat [ ppr name, ppr kc_binders, ppr kc_res_kind + , ppr kvs, ppr kc_binders', ppr kc_res_kind' ] + + ; return (mkTcTyCon name + (map (mkNamedBinder Invisible) kvs ++ kc_binders') + kc_res_kind' + (mightBeUnsaturatedTyCon tc)) } generaliseTCD :: TcTypeEnv - -> LTyClDecl Name -> TcM [(Name, Kind, Maybe Arity)] + -> LTyClDecl Name -> TcM [TcTyCon] generaliseTCD kind_env (L _ decl) | ClassDecl { tcdLName = (L _ name), tcdATs = ats } <- decl = do { first <- generalise kind_env name @@ -336,19 +344,15 @@ kcTyClGroup (TyClGroup { group_tyclds = decls }) ; return [res] } generaliseFamDecl :: TcTypeEnv - -> FamilyDecl Name -> TcM (Name, Kind, Maybe Arity) + -> FamilyDecl Name -> TcM TcTyCon generaliseFamDecl kind_env (FamilyDecl { fdLName = L _ name }) = generalise kind_env name -mkTcTyConPair :: Name -> TcKind - -> Maybe Arity -- ^ Nothing <=> tycon can be unsaturated - -> (Name, TcTyThing) +mkTcTyConPair :: TcTyCon -> (Name, TcTyThing) -- Makes a binding to put in the local envt, binding --- a name to a TcTyCon with the specified kind -mkTcTyConPair name kind Nothing - = (name, ATcTyCon (mkTcTyCon name kind True 0)) -mkTcTyConPair name kind (Just arity) - = (name, ATcTyCon (mkTcTyCon name kind False arity)) +-- a name to a TcTyCon +mkTcTyConPair tc + = (getName tc, ATcTyCon tc) mk_thing_env :: [LTyClDecl Name] -> [(Name, TcTyThing)] mk_thing_env [] = [] @@ -388,26 +392,28 @@ getInitialKind :: TyClDecl Name -- No family instances are passed to getInitialKinds getInitialKind decl@(ClassDecl { tcdLName = L _ name, tcdTyVars = ktvs, tcdATs = ats }) - = do { (cl_kind, inner_prs) <- + = do { (cl_binders, cl_kind, inner_prs) <- kcHsTyVarBndrs (hsDeclHasCusk decl) ktvs $ \_ _ -> do { inner_prs <- getFamDeclInitialKinds ats ; return (constraintKind, inner_prs) } - ; cl_kind <- zonkTcType cl_kind - ; let main_pr = mkTcTyConPair name cl_kind Nothing + ; cl_binders <- mapM zonkTcTyBinder cl_binders + ; cl_kind <- zonkTcType cl_kind + ; let main_pr = mkTcTyConPair (mkTcTyCon name cl_binders cl_kind True) ; return (main_pr : inner_prs) } getInitialKind decl@(DataDecl { tcdLName = L _ name , tcdTyVars = ktvs , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig , dd_cons = cons } }) - = do { (decl_kind, _) <- + = do { (decl_binders, decl_kind, _) <- kcHsTyVarBndrs (hsDeclHasCusk decl) ktvs $ \_ _ -> do { res_k <- case m_sig of Just ksig -> tcLHsKind ksig Nothing -> return liftedTypeKind ; return (res_k, ()) } - ; decl_kind <- zonkTcType decl_kind - ; let main_pr = mkTcTyConPair name decl_kind Nothing + ; decl_binders <- mapM zonkTcTyBinder decl_binders + ; decl_kind <- zonkTcType decl_kind + ; let main_pr = mkTcTyConPair (mkTcTyCon name decl_binders decl_kind True) inner_prs = [ (unLoc con, APromotionErr RecDataConPE) | L _ con' <- cons, con <- getConNames con' ] ; return (main_pr : inner_prs) } @@ -431,7 +437,7 @@ getFamDeclInitialKind decl@(FamilyDecl { fdLName = L _ name , fdTyVars = ktvs , fdResultSig = L _ resultSig , fdInfo = info }) - = do { (fam_kind, _) <- + = do { (fam_binders, fam_kind, _) <- kcHsTyVarBndrs (famDeclHasCusk decl) ktvs $ \_ _ -> do { res_k <- case resultSig of KindSig ki -> tcLHsKind ki @@ -442,42 +448,43 @@ getFamDeclInitialKind decl@(FamilyDecl { fdLName = L _ name -- by default | otherwise -> newMetaKindVar ; return (res_k, ()) } - ; fam_kind <- zonkTcType fam_kind - ; return [ mkTcTyConPair name fam_kind m_arity ] } + ; fam_binders <- mapM zonkTcTyBinder fam_binders + ; fam_kind <- zonkTcType fam_kind + ; return [ mkTcTyConPair (mkTcTyCon name fam_binders fam_kind unsat) ] } where - m_arity = case info of - DataFamily -> Nothing - OpenTypeFamily -> Just (length $ hsQTvExplicit ktvs) - ClosedTypeFamily _ -> Just (length $ hsQTvExplicit ktvs) + unsat = case info of + DataFamily -> True + OpenTypeFamily -> False + ClosedTypeFamily _ -> False ---------------- kcSynDecls :: [SCC (LTyClDecl Name)] -> TcM TcLclEnv -- Kind bindings kcSynDecls [] = getLclEnv kcSynDecls (group : groups) - = do { (n,k,arity) <- kcSynDecl1 group - ; tcExtendKindEnv2 [ mkTcTyConPair n k (Just arity) ] $ + = do { tc <- kcSynDecl1 group + ; tcExtendKindEnv2 [ mkTcTyConPair tc ] $ kcSynDecls groups } kcSynDecl1 :: SCC (LTyClDecl Name) - -> TcM (Name,TcKind,Arity) -- Kind bindings + -> TcM TcTyCon -- Kind bindings kcSynDecl1 (AcyclicSCC (L _ decl)) = kcSynDecl decl kcSynDecl1 (CyclicSCC decls) = do { recSynErr decls; failM } -- Fail here to avoid error cascade -- of out-of-scope tycons -kcSynDecl :: TyClDecl Name -> TcM (Name, TcKind, Arity) +kcSynDecl :: TyClDecl Name -> TcM TcTyCon kcSynDecl decl@(SynDecl { tcdTyVars = hs_tvs, tcdLName = L _ name , tcdRhs = rhs }) -- Returns a possibly-unzonked kind = tcAddDeclCtxt decl $ - do { (syn_kind, _) <- + do { (syn_binders, syn_kind, _) <- kcHsTyVarBndrs (hsDeclHasCusk decl) hs_tvs $ \_ _ -> do { traceTc "kcd1" (ppr name <+> brackets (ppr hs_tvs)) ; (_, rhs_kind) <- tcLHsType rhs ; traceTc "kcd2" (ppr name) ; return (rhs_kind, ()) } - ; return (name, syn_kind, length $ hsQTvExplicit hs_tvs) } + ; return (mkTcTyCon name syn_binders syn_kind False) } kcSynDecl decl = pprPanic "kcSynDecl" (ppr decl) ------------------------------------------------------------------------ @@ -525,10 +532,11 @@ kcTyClDecl (FamDecl (FamilyDecl { fdLName = L _ fam_tc_name -- do anything here = case fd_info of ClosedTypeFamily (Just eqns) -> - do { tc_kind <- kcLookupKind fam_tc_name + do { (tc_binders, tc_res_kind) <- kcLookupKind fam_tc_name ; let fam_tc_shape = ( fam_tc_name , length $ hsQTvExplicit hs_tvs - , tc_kind ) + , tc_binders + , tc_res_kind ) ; mapM_ (kcTyFamInstEqn fam_tc_shape) eqns } _ -> return () @@ -676,15 +684,15 @@ tcTyClDecl1 parent _rec_info (FamDecl { tcdFam = fd }) tcTyClDecl1 _parent rec_info (SynDecl { tcdLName = L _ tc_name, tcdTyVars = tvs, tcdRhs = rhs }) = ASSERT( isNothing _parent ) - tcTyClTyVars tc_name tvs $ \ kvs' tvs' full_kind res_kind -> - tcTySynRhs rec_info tc_name (kvs' ++ tvs') full_kind res_kind rhs + tcTyClTyVars tc_name tvs $ \ kvs' tvs' binders res_kind -> + tcTySynRhs rec_info tc_name (kvs' ++ tvs') binders res_kind rhs -- "data/newtype" declaration tcTyClDecl1 _parent rec_info (DataDecl { tcdLName = L _ tc_name, tcdTyVars = tvs, tcdDataDefn = defn }) = ASSERT( isNothing _parent ) - tcTyClTyVars tc_name tvs $ \ kvs' tvs' tycon_kind res_kind -> - tcDataDefn rec_info tc_name (kvs' ++ tvs') tycon_kind res_kind defn + tcTyClTyVars tc_name tvs $ \ kvs' tvs' tycon_binders res_kind -> + tcDataDefn rec_info tc_name (kvs' ++ tvs') tycon_binders res_kind defn tcTyClDecl1 _parent rec_info (ClassDecl { tcdLName = L _ class_name, tcdTyVars = tvs @@ -693,13 +701,13 @@ tcTyClDecl1 _parent rec_info , tcdATs = ats, tcdATDefs = at_defs }) = ASSERT( isNothing _parent ) do { clas <- fixM $ \ clas -> - tcTyClTyVars class_name tvs $ \ kvs' tvs' full_kind res_kind -> + tcTyClTyVars class_name tvs $ \ kvs' tvs' binders res_kind -> do { MASSERT( isConstraintKind res_kind ) -- This little knot is just so we can get -- hold of the name of the class TyCon, which we -- need to look up its recursiveness ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr kvs' $$ - ppr tvs' $$ ppr full_kind) + ppr tvs' $$ ppr binders) ; let tycon_name = tyConName (classTyCon clas) tc_isrec = rti_is_rec rec_info tycon_name roles = rti_roles rec_info tycon_name @@ -712,7 +720,7 @@ tcTyClDecl1 _parent rec_info ; at_stuff <- tcClassATs class_name clas ats at_defs ; mindef <- tcClassMinimalDef class_name sigs sig_stuff ; clas <- buildClass - class_name (kvs' ++ tvs') roles ctxt' full_kind + class_name (kvs' ++ tvs') roles ctxt' binders fds' at_stuff sig_stuff mindef tc_isrec ; traceTc "tcClassDecl" (ppr fundeps $$ ppr (kvs' ++ tvs') $$ @@ -730,25 +738,26 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info, fdLName = tc_lname@(L _ tc_na , fdTyVars = tvs, fdResultSig = L _ sig , fdInjectivityAnn = inj }) | DataFamily <- fam_info - = tcTyClTyVars tc_name tvs $ \ kvs' tvs' tycon_kind res_kind -> do + = tcTyClTyVars tc_name tvs $ \ kvs' tvs' binders res_kind -> do { traceTc "data family:" (ppr tc_name) ; checkFamFlag tc_name - ; extra_tvs <- tcDataKindSig res_kind + ; (extra_tvs, extra_binders, real_res_kind) <- tcDataKindSig res_kind ; tc_rep_name <- newTyConRepName tc_name ; let final_tvs = (kvs' ++ tvs') `chkAppend` extra_tvs -- we may not need these - tycon = mkFamilyTyCon tc_name tycon_kind final_tvs + tycon = mkFamilyTyCon tc_name (binders `chkAppend` extra_binders) + real_res_kind final_tvs (resultVariableName sig) (DataFamilyTyCon tc_rep_name) parent NotInjective ; return tycon } | OpenTypeFamily <- fam_info - = tcTyClTyVars tc_name tvs $ \ kvs' tvs' full_kind _res_kind -> do + = tcTyClTyVars tc_name tvs $ \ kvs' tvs' binders res_kind -> do { traceTc "open type family:" (ppr tc_name) ; checkFamFlag tc_name ; let all_tvs = kvs' ++ tvs' ; inj' <- tcInjectivity all_tvs inj - ; let tycon = mkFamilyTyCon tc_name full_kind all_tvs + ; let tycon = mkFamilyTyCon tc_name binders res_kind all_tvs (resultVariableName sig) OpenSynFamilyTyCon parent inj' ; return tycon } @@ -759,11 +768,12 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info, fdLName = tc_lname@(L _ tc_na do { traceTc "Closed type family:" (ppr tc_name) -- the variables in the header scope only over the injectivity -- declaration but this is not involved here - ; (tvs', inj', kind) <- tcTyClTyVars tc_name tvs - $ \ kvs' tvs' full_kind _res_kind -> - do { let all_tvs = kvs' ++ tvs' - ; inj' <- tcInjectivity all_tvs inj - ; return (all_tvs, inj', full_kind) } + ; (tvs', inj', binders, res_kind) + <- tcTyClTyVars tc_name tvs + $ \ kvs' tvs' binders res_kind -> + do { let all_tvs = kvs' ++ tvs' + ; inj' <- tcInjectivity all_tvs inj + ; return (all_tvs, inj', binders, res_kind) } ; checkFamFlag tc_name -- make sure we have -XTypeFamilies @@ -771,14 +781,14 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info, fdLName = tc_lname@(L _ tc_na -- but eqns might be empty in the Just case as well ; case mb_eqns of Nothing -> - return $ mkFamilyTyCon tc_name kind tvs' + return $ mkFamilyTyCon tc_name binders res_kind tvs' (resultVariableName sig) AbstractClosedSynFamilyTyCon parent inj' Just eqns -> do { -- Process the equations, creating CoAxBranches - ; let fam_tc_shape = (tc_name, length $ hsQTvExplicit tvs, kind) + ; let fam_tc_shape = (tc_name, length $ hsQTvExplicit tvs, binders, res_kind) ; branches <- mapM (tcTyFamInstEqn fam_tc_shape Nothing) eqns -- Do not attempt to drop equations dominated by earlier @@ -800,7 +810,7 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info, fdLName = tc_lname@(L _ tc_na | null eqns = Nothing -- mkBranchedCoAxiom fails on empty list | otherwise = Just (mkBranchedCoAxiom co_ax_name fam_tc branches) - fam_tc = mkFamilyTyCon tc_name kind tvs' (resultVariableName sig) + fam_tc = mkFamilyTyCon tc_name binders res_kind tvs' (resultVariableName sig) (ClosedSynFamilyTyCon mb_co_ax) parent inj' -- We check for instance validity later, when doing validity @@ -856,27 +866,27 @@ tcInjectivity tvs (Just (L loc (InjectivityAnn _ lInjNames))) tcTySynRhs :: RecTyInfo -> Name - -> [TyVar] -> Kind -> Kind + -> [TyVar] -> [TyBinder] -> Kind -> LHsType Name -> TcM TyCon -tcTySynRhs rec_info tc_name tvs full_kind res_kind hs_ty +tcTySynRhs rec_info tc_name tvs binders res_kind hs_ty = do { env <- getLclEnv ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env)) ; rhs_ty <- solveEqualities $ tcCheckLHsType hs_ty res_kind ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty ; let roles = rti_roles rec_info tc_name - tycon = mkSynonymTyCon tc_name full_kind tvs roles rhs_ty + tycon = mkSynonymTyCon tc_name binders res_kind tvs roles rhs_ty ; return tycon } tcDataDefn :: RecTyInfo -> Name - -> [TyVar] -> Kind -> Kind + -> [TyVar] -> [TyBinder] -> Kind -> HsDataDefn Name -> TcM TyCon -- NB: not used for newtype/data instances (whether associated or not) tcDataDefn rec_info -- Knot-tied; don't look at this eagerly - tc_name tvs tycon_kind res_kind + tc_name tvs tycon_binders res_kind (HsDataDefn { dd_ND = new_or_data, dd_cType = cType , dd_ctxt = ctxt, dd_kindSig = mb_ksig , dd_cons = cons }) - = do { extra_tvs <- tcDataKindSig res_kind + = do { (extra_tvs, extra_bndrs, real_res_kind) <- tcDataKindSig res_kind ; let final_tvs = tvs `chkAppend` extra_tvs roles = rti_roles rec_info tc_name @@ -897,7 +907,8 @@ tcDataDefn rec_info -- Knot-tied; don't look at this eagerly ; data_cons <- tcConDecls new_or_data tycon (final_tvs, res_ty) cons ; tc_rhs <- mk_tc_rhs is_boot tycon data_cons ; tc_rep_nm <- newTyConRepName tc_name - ; return (mkAlgTyCon tc_name tycon_kind final_tvs roles + ; return (mkAlgTyCon tc_name (tycon_binders `chkAppend` extra_bndrs) + real_res_kind final_tvs roles (fmap unLoc cType) stupid_theta tc_rhs (VanillaAlgTyCon tc_rep_nm) @@ -987,7 +998,7 @@ tcDefaultAssocDecl fam_tc [L loc (TyFamEqn { tfe_tycon = L _ tc_name setSrcSpan loc $ tcAddFamInstCtxt (text "default type instance") tc_name $ do { traceTc "tcDefaultAssocDecl" (ppr tc_name) - ; let shape@(fam_tc_name, fam_arity, _) = famTyConShape fam_tc + ; let shape@(fam_tc_name, fam_arity, _, _) = famTyConShape fam_tc -- Kind of family check ; ASSERT( fam_tc_name == tc_name ) @@ -1053,7 +1064,7 @@ kcTyFamInstEqn fam_tc_shape tcTyFamInstEqn :: FamTyConShape -> Maybe ClsInfo -> LTyFamInstEqn Name -> TcM CoAxBranch -- Needs to be here, not in TcInstDcls, because closed families -- (typechecked here) have TyFamInstEqns -tcTyFamInstEqn fam_tc_shape@(fam_tc_name,_,_) mb_clsinfo +tcTyFamInstEqn fam_tc_shape@(fam_tc_name,_,_,_) mb_clsinfo (L loc (TyFamEqn { tfe_tycon = L _ eqn_tc_name , tfe_pats = pats , tfe_rhs = hs_ty })) @@ -1130,13 +1141,15 @@ two bad things could happen: -} ----------------- -type FamTyConShape = (Name, Arity, Kind) -- See Note [Type-checking type patterns] +type FamTyConShape = (Name, Arity, [TyBinder], Kind) + -- See Note [Type-checking type patterns] famTyConShape :: TyCon -> FamTyConShape famTyConShape fam_tc = ( tyConName fam_tc , length $ filterOutInvisibleTyVars fam_tc (tyConTyVars fam_tc) - , tyConKind fam_tc ) + , tyConBinders fam_tc + , tyConResKind fam_tc ) tc_fam_ty_pats :: FamTyConShape -> Maybe ClsInfo @@ -1155,21 +1168,24 @@ tc_fam_ty_pats :: FamTyConShape -- In that case, the type variable 'a' will *already be in scope* -- (and, if C is poly-kinded, so will its kind parameter). -tc_fam_ty_pats (name, _, kind) mb_clsinfo +tc_fam_ty_pats (name, _, binders, res_kind) mb_clsinfo (HsIB { hsib_body = arg_pats, hsib_vars = tv_names }) kind_checker = do { -- Kind-check and quantify -- See Note [Quantifying over family patterns] - (_, (res_kind, typats)) <- tcImplicitTKBndrs tv_names $ - do { (res_kind, args, leftovers, n) - <- tcInferArgs name kind (snd <$> mb_clsinfo) arg_pats + (_, (insted_res_kind, typats)) <- tcImplicitTKBndrs tv_names $ + do { (insting_subst, _leftover_binders, args, leftovers, n) + <- tcInferArgs name binders (snd <$> mb_clsinfo) arg_pats ; case leftovers of hs_ty:_ -> addErrTc $ too_many_args hs_ty n _ -> return () - ; kind_checker res_kind - ; return ((res_kind, args), emptyVarSet) } + -- don't worry about leftover_binders; TcValidity catches them + + ; let insted_res_kind = substTyUnchecked insting_subst res_kind + ; kind_checker insted_res_kind + ; return ((insted_res_kind, args), emptyVarSet) } - ; return (typats, res_kind) } + ; return (typats, insted_res_kind) } where too_many_args hs_ty n = hang (text "Too many parameters to" <+> ppr name <> colon) @@ -1186,7 +1202,7 @@ tcFamTyPats :: FamTyConShape -> [TcType] -- Kind and type arguments -> Kind -> TcM a) -- NB: You can use solveEqualities here. -> TcM a -tcFamTyPats fam_shape@(name,_,_) mb_clsinfo pats kind_checker thing_inside +tcFamTyPats fam_shape@(name,_,_,_) mb_clsinfo pats kind_checker thing_inside = do { (typats, res_kind) <- solveEqualities $ -- See Note [Constraints in patterns] tc_fam_ty_pats fam_shape mb_clsinfo pats kind_checker diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs index 00b3a0f07b..972cbae749 100644 --- a/compiler/typecheck/TcType.hs +++ b/compiler/typecheck/TcType.hs @@ -22,7 +22,7 @@ module TcType ( -- Types TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType, TcTyVar, TcTyVarSet, TcDTyVarSet, TcTyCoVarSet, TcDTyCoVarSet, - TcKind, TcCoVar, TcTyCoVar, TcTyBinder, + TcKind, TcCoVar, TcTyCoVar, TcTyBinder, TcTyCon, ExpType(..), ExpSigmaType, ExpRhoType, mkCheckExpType, @@ -121,7 +121,7 @@ module TcType ( -------------------------------- -- Rexported from Kind Kind, typeKind, - unliftedTypeKind, liftedTypeKind, + liftedTypeKind, constraintKind, isLiftedTypeKind, isUnliftedTypeKind, classifiesTypeWithValues, @@ -140,7 +140,7 @@ module TcType ( mkClassPred, isDictLikeTy, tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy, - isLevityVar, isLevityPolymorphic, isLevityPolymorphic_maybe, + isRuntimeRepVar, isRuntimeRepPolymorphic, isVisibleBinder, isInvisibleBinder, -- Type substitutions @@ -269,6 +269,7 @@ type TcTyCoVar = Var -- Either a TcTyVar or a CoVar -- a cannot occur inside a MutTyVar in T; that is, -- T is "flattened" before quantifying over a type TcTyBinder = TyBinder +type TcTyCon = TyCon -- these can be the TcTyCon constructor -- These types do not have boxy type variables in them type TcPredType = PredType @@ -1375,9 +1376,8 @@ tc_eq_type view_fun orig_ty1 orig_ty2 = go Visible orig_env orig_ty1 orig_ty2 -- the repeat Visible is necessary because tycons can legitimately -- be oversaturated where - k = tyConKind tc - (bndrs, _) = splitPiTys k - viss = map binderVisibility bndrs + bndrs = tyConBinders tc + viss = map binderVisibility bndrs check :: VisibilityFlag -> Bool -> Maybe VisibilityFlag check _ True = Nothing diff --git a/compiler/typecheck/TcTypeNats.hs b/compiler/typecheck/TcTypeNats.hs index e7fb85fdbe..e6a6c7ed70 100644 --- a/compiler/typecheck/TcTypeNats.hs +++ b/compiler/typecheck/TcTypeNats.hs @@ -100,7 +100,8 @@ typeNatExpTyCon = mkTypeNatFunTyCon2 name typeNatLeqTyCon :: TyCon typeNatLeqTyCon = mkFamilyTyCon name - (mkFunTys [ typeNatKind, typeNatKind ] boolTy) + (map mkAnonBinder [ typeNatKind, typeNatKind ]) + boolTy (mkTemplateTyVars [ typeNatKind, typeNatKind ]) Nothing (BuiltInSynFamTyCon ops) @@ -119,7 +120,8 @@ typeNatLeqTyCon = typeNatCmpTyCon :: TyCon typeNatCmpTyCon = mkFamilyTyCon name - (mkFunTys [ typeNatKind, typeNatKind ] orderingKind) + (map mkAnonBinder [ typeNatKind, typeNatKind ]) + orderingKind (mkTemplateTyVars [ typeNatKind, typeNatKind ]) Nothing (BuiltInSynFamTyCon ops) @@ -138,7 +140,8 @@ typeNatCmpTyCon = typeSymbolCmpTyCon :: TyCon typeSymbolCmpTyCon = mkFamilyTyCon name - (mkFunTys [ typeSymbolKind, typeSymbolKind ] orderingKind) + (map mkAnonBinder [ typeSymbolKind, typeSymbolKind ]) + orderingKind (mkTemplateTyVars [ typeSymbolKind, typeSymbolKind ]) Nothing (BuiltInSynFamTyCon ops) @@ -162,7 +165,8 @@ typeSymbolCmpTyCon = mkTypeNatFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon mkTypeNatFunTyCon2 op tcb = mkFamilyTyCon op - (mkFunTys [ typeNatKind, typeNatKind ] typeNatKind) + (map mkAnonBinder [ typeNatKind, typeNatKind ]) + typeNatKind (mkTemplateTyVars [ typeNatKind, typeNatKind ]) Nothing (BuiltInSynFamTyCon tcb) diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs index e25ff2191c..77651c8568 100644 --- a/compiler/typecheck/TcUnify.hs +++ b/compiler/typecheck/TcUnify.hs @@ -381,16 +381,9 @@ matchExpectedTyConApp tc orig_ty -- because that'll make types that are utterly ill-kinded. -- This happened in Trac #7368 defer - = ASSERT2( classifiesTypeWithValues res_kind, ppr tc ) - do { (k_subst, kvs') <- newMetaTyVars kvs - ; let arg_kinds' = substTys k_subst arg_kinds - kappa_tys = mkTyVarTys kvs' - ; tau_tys <- mapM newFlexiTyVarTy arg_kinds' - ; co <- unifyType noThing (mkTyConApp tc (kappa_tys ++ tau_tys)) orig_ty - ; return (co, kappa_tys ++ tau_tys) } - - (bndrs, res_kind) = splitPiTys (tyConKind tc) - (kvs, arg_kinds) = partitionBinders bndrs + = do { (_subst, args) <- tcInstBinders (tyConBinders tc) + ; co <- unifyType noThing (mkTyConApp tc args) orig_ty + ; return (co, args) } ---------------------- matchExpectedAppTy :: TcRhoType -- orig_ty @@ -1181,13 +1174,13 @@ uType origin t_or_k orig_ty1 orig_ty2 do { cos <- zipWith3M (uType origin) t_or_ks tys1 tys2 ; return $ mkTyConAppCo Nominal tc1 cos } where - (bndrs, _) = splitPiTys (tyConKind tc1) + bndrs = tyConBinders tc1 t_or_ks = case t_or_k of KindLevel -> repeat KindLevel TypeLevel -> map (\bndr -> if isNamedBinder bndr then KindLevel - else TypeLevel) - bndrs + else TypeLevel) bndrs ++ + repeat TypeLevel go (LitTy m) ty@(LitTy n) | m == n diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs index 56cb348669..319c15dd77 100644 --- a/compiler/typecheck/TcValidity.hs +++ b/compiler/typecheck/TcValidity.hs @@ -945,7 +945,7 @@ tyConArityErr tc tks -- tc_type_arity = number of *type* args expected -- tc_type_args = number of *type* args encountered - tc_type_arity = count isVisibleBinder $ fst $ splitPiTys (tyConKind tc) + tc_type_arity = count isVisibleBinder $ tyConBinders tc tc_type_args = length vis_tks arityErr :: Outputable a => String -> a -> Int -> Int -> SDoc @@ -1583,7 +1583,7 @@ checkValidFamPats mb_clsinfo fam_tc tvs cvs ty_pats ; checkConsistentFamInst mb_clsinfo fam_tc tvs ty_pats } where fam_arity = tyConArity fam_tc - fam_bndrs = take fam_arity $ fst $ splitPiTys (tyConKind fam_tc) + fam_bndrs = tyConBinders fam_tc checkValidTypePat :: Type -> TcM () diff --git a/compiler/types/Kind.hs b/compiler/types/Kind.hs index 1ce0bbf0ed..ac7fc586aa 100644 --- a/compiler/types/Kind.hs +++ b/compiler/types/Kind.hs @@ -14,7 +14,7 @@ module Kind ( classifiesTypeWithValues, isStarKind, isStarKindSynonymTyCon, - isLevityPolymorphic, isLevityPolymorphic_maybe + isRuntimeRepPolymorphic ) where #include "HsVersions.h" @@ -23,9 +23,8 @@ import {-# SOURCE #-} Type ( typeKind, coreViewOneStarKind ) import TyCoRep import TyCon -import Var +import VarSet ( isEmptyVarSet ) import PrelNames -import Data.Maybe import Util ( (<&&>) ) {- @@ -78,19 +77,11 @@ returnsTyCon _ _ = False returnsConstraintKind :: Kind -> Bool returnsConstraintKind = returnsTyCon constraintKindTyConKey --- | Tests whether the given type looks like "TYPE v", where v is a variable. -isLevityPolymorphic :: Kind -> Bool -isLevityPolymorphic = isJust . isLevityPolymorphic_maybe - --- | Retrieves a levity variable in the given kind, if the kind is of the --- form "TYPE v". -isLevityPolymorphic_maybe :: Kind -> Maybe TyVar -isLevityPolymorphic_maybe k - | Just k' <- coreViewOneStarKind k = isLevityPolymorphic_maybe k' -isLevityPolymorphic_maybe (TyConApp tc [TyVarTy v]) - | tc `hasKey` tYPETyConKey - = Just v -isLevityPolymorphic_maybe _ = Nothing +-- | Tests whether the given type (which should look like "TYPE ...") has any +-- free variables +isRuntimeRepPolymorphic :: Kind -> Bool +isRuntimeRepPolymorphic k + = not $ isEmptyVarSet $ tyCoVarsOfType k -------------------------------------------- -- Kinding for arrow (->) @@ -98,7 +89,7 @@ isLevityPolymorphic_maybe _ = Nothing -- arg -> res okArrowArgKind, okArrowResultKind :: Kind -> Bool -okArrowArgKind = classifiesTypeWithValues <&&> (not . isLevityPolymorphic) +okArrowArgKind = classifiesTypeWithValues <&&> (not . isRuntimeRepPolymorphic) okArrowResultKind = classifiesTypeWithValues ----------------------------------------- @@ -119,8 +110,9 @@ classifiesTypeWithValues _ = False -- | Is this kind equivalent to *? isStarKind :: Kind -> Bool isStarKind k | Just k' <- coreViewOneStarKind k = isStarKind k' -isStarKind (TyConApp tc [TyConApp l []]) = tc `hasKey` tYPETyConKey - && l `hasKey` liftedDataConKey +isStarKind (TyConApp tc [TyConApp ptr_rep []]) + = tc `hasKey` tYPETyConKey + && ptr_rep `hasKey` ptrRepLiftedDataConKey isStarKind _ = False -- See Note [Kind Constraint and kind *] diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs index ad583eab3f..56247300b9 100644 --- a/compiler/types/TyCoRep.hs +++ b/compiler/types/TyCoRep.hs @@ -37,10 +37,10 @@ module TyCoRep ( -- Functions over types mkTyConTy, mkTyVarTy, mkTyVarTys, - mkFunTy, mkFunTys, + mkFunTy, mkFunTys, mkForAllTys, isLiftedTypeKind, isUnliftedTypeKind, - isCoercionType, isLevityTy, isLevityVar, - isLevityKindedTy, dropLevityArgs, + isCoercionType, isRuntimeRepTy, isRuntimeRepVar, + isRuntimeRepKindedTy, dropRuntimeRepArgs, sameVis, -- Functions over binders @@ -465,6 +465,10 @@ mkFunTy arg res = ForAllTy (Anon arg) res mkFunTys :: [Type] -> Type -> Type mkFunTys tys ty = foldr mkFunTy ty tys +-- | Wraps foralls over the type using the provided 'TyVar's from left to right +mkForAllTys :: [TyBinder] -> Type -> Type +mkForAllTys tyvars ty = foldr ForAllTy ty tyvars + -- | Does this type classify a core Coercion? isCoercionType :: Type -> Bool isCoercionType (TyConApp tc tys) @@ -514,39 +518,47 @@ 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 *. isLiftedTypeKind :: Kind -> Bool isLiftedTypeKind ki | Just ki' <- coreView ki = isLiftedTypeKind ki' -isLiftedTypeKind (TyConApp tc [TyConApp lev []]) - = tc `hasKey` tYPETyConKey && lev `hasKey` liftedDataConKey +isLiftedTypeKind (TyConApp tc [TyConApp ptr_rep []]) + = tc `hasKey` tYPETyConKey + && ptr_rep `hasKey` ptrRepLiftedDataConKey isLiftedTypeKind _ = False isUnliftedTypeKind :: Kind -> Bool isUnliftedTypeKind ki | Just ki' <- coreView ki = isUnliftedTypeKind ki' -isUnliftedTypeKind (TyConApp tc [TyConApp lev []]) - = tc `hasKey` tYPETyConKey && lev `hasKey` unliftedDataConKey +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 --- | Is this the type 'Levity'? -isLevityTy :: Type -> Bool -isLevityTy ty | Just ty' <- coreView ty = isLevityTy ty' -isLevityTy (TyConApp tc []) = tc `hasKey` levityTyConKey -isLevityTy _ = False +-- | Is this the type 'RuntimeRep'? +isRuntimeRepTy :: Type -> Bool +isRuntimeRepTy ty | Just ty' <- coreView ty = isRuntimeRepTy ty' +isRuntimeRepTy (TyConApp tc []) = tc `hasKey` runtimeRepTyConKey +isRuntimeRepTy _ = False --- | Is this a type of kind Levity? (e.g. Lifted, Unlifted) -isLevityKindedTy :: Type -> Bool -isLevityKindedTy = isLevityTy . typeKind +-- | Is this a type of kind RuntimeRep? (e.g. PtrRep) +isRuntimeRepKindedTy :: Type -> Bool +isRuntimeRepKindedTy = isRuntimeRepTy . typeKind --- | Is a tyvar of type 'Levity'? -isLevityVar :: TyVar -> Bool -isLevityVar = isLevityTy . tyVarKind +-- | Is a tyvar of type 'RuntimeRep'? +isRuntimeRepVar :: TyVar -> Bool +isRuntimeRepVar = isRuntimeRepTy . tyVarKind --- | Drops prefix of Levity constructors in 'TyConApp's. Useful for e.g. --- dropping 'Lifted and 'Unlifted arguments of unboxed tuple TyCon applications: +-- | Drops prefix of RuntimeRep constructors in 'TyConApp's. Useful for e.g. +-- dropping 'PtrRep arguments of unboxed tuple TyCon applications: -- --- dropLevityArgs ['Lifted, 'Unlifted, String, Int#] == [String, Int#] +-- dropRuntimeRepArgs [ 'PtrRepLifted, 'PtrRepUnlifted +-- , String, Int# ] == [String, Int#] -- -dropLevityArgs :: [Type] -> [Type] -dropLevityArgs = dropWhile isLevityKindedTy +dropRuntimeRepArgs :: [Type] -> [Type] +dropRuntimeRepArgs = dropWhile isRuntimeRepKindedTy {- %************************************************************************ @@ -2657,11 +2669,14 @@ pprTyTcApp p tc tys = text "(TypeError ...)" -- Suppress detail unles you _really_ want to see | tc `hasKey` tYPETyConKey - , [TyConApp lev_tc []] <- tys - = if | lev_tc `hasKey` liftedDataConKey -> - unicodeSyntax (char '★') (char '*') - | lev_tc `hasKey` unliftedDataConKey -> char '#' - | otherwise -> ppr_deflt + , [TyConApp ptr_rep []] <- tys + , ptr_rep `hasKey` ptrRepLiftedDataConKey + = unicodeSyntax (char '★') (char '*') + + | tc `hasKey` tYPETyConKey + , [TyConApp ptr_rep []] <- tys + , ptr_rep `hasKey` ptrRepUnliftedDataConKey + = char '#' | otherwise = ppr_deflt @@ -2669,27 +2684,33 @@ pprTyTcApp p tc tys ppr_deflt = pprTcAppTy p ppr_type tc tys pprTcAppTy :: TyPrec -> (TyPrec -> Type -> SDoc) -> TyCon -> [Type] -> SDoc -pprTcAppTy = pprTcApp id +pprTcAppTy p pp tc tys + = getPprStyle $ \style -> pprTcApp style id p pp tc tys pprTcAppCo :: TyPrec -> (TyPrec -> Coercion -> SDoc) -> TyCon -> [Coercion] -> SDoc -pprTcAppCo = pprTcApp (pFst . coercionKind) +pprTcAppCo p pp tc cos + = getPprStyle $ \style -> + pprTcApp style (pFst . coercionKind) p pp tc cos -pprTcApp :: (a -> Type) -> TyPrec -> (TyPrec -> a -> SDoc) -> TyCon -> [a] -> SDoc +pprTcApp :: PprStyle + -> (a -> Type) -> TyPrec -> (TyPrec -> a -> SDoc) -> TyCon -> [a] -> SDoc -- Used for both types and coercions, hence polymorphism -pprTcApp _ _ pp tc [ty] +pprTcApp _ _ _ pp tc [ty] | tc `hasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp TopPrec ty) | tc `hasKey` parrTyConKey = pprPromotionQuote tc <> paBrackets (pp TopPrec ty) -pprTcApp to_type p pp tc tys - | Just sort <- tyConTuple_maybe tc +pprTcApp style to_type p pp tc tys + | not (debugStyle style) + , Just sort <- tyConTuple_maybe tc , let arity = tyConArity tc , arity == length tys , let num_to_drop = case sort of UnboxedTuple -> arity `div` 2 _ -> 0 = pprTupleApp p pp tc sort (drop num_to_drop tys) - | Just dc <- isPromotedDataCon_maybe tc + | not (debugStyle style) + , Just dc <- isPromotedDataCon_maybe tc , let dc_tc = dataConTyCon dc , Just tup_sort <- tyConTuple_maybe dc_tc , let arity = tyConArity dc_tc -- E.g. 3 for (,,) k1 k2 k3 t1 t2 t3 @@ -2700,7 +2721,6 @@ pprTcApp to_type p pp tc tys | otherwise = sdocWithDynFlags $ \dflags -> - getPprStyle $ \style -> pprTcApp_help to_type p pp tc tys dflags style where diff --git a/compiler/types/TyCoRep.hs-boot b/compiler/types/TyCoRep.hs-boot index 76a5abf2f1..5236bcc45f 100644 --- a/compiler/types/TyCoRep.hs-boot +++ b/compiler/types/TyCoRep.hs-boot @@ -11,6 +11,8 @@ data LeftOrRight data UnivCoProvenance data TCvSubst +mkForAllTys :: [TyBinder] -> Type -> Type + type PredType = Type type Kind = Type type ThetaType = [PredType] diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs index e6fe3511d4..5d017325cc 100644 --- a/compiler/types/TyCon.hs +++ b/compiler/types/TyCon.hs @@ -15,6 +15,7 @@ module TyCon( AlgTyConRhs(..), visibleDataCons, AlgTyConFlav(..), isNoParent, FamTyConFlav(..), Role(..), Injectivity(..), + RuntimeRepInfo(..), -- ** Field labels tyConFieldLabels, tyConFieldLabelEnv, @@ -82,6 +83,8 @@ module TyCon( newTyConRhs, newTyConEtadArity, newTyConEtadRhs, unwrapNewTyCon_maybe, unwrapNewTyConEtad_maybe, algTcFields, + tyConRuntimeRepInfo, + tyConBinders, tyConResKind, -- ** Manipulating TyCons expandSynTyCon_maybe, @@ -96,7 +99,7 @@ module TyCon( -- * Primitive representations of Types PrimRep(..), PrimElemRep(..), - tyConPrimRep, isVoidRep, isGcPtrRep, + isVoidRep, isGcPtrRep, primRepSizeW, primElemRepSizeB, primRepIsFloat, @@ -107,7 +110,9 @@ module TyCon( #include "HsVersions.h" -import {-# SOURCE #-} TyCoRep ( Kind, Type, PredType ) +import {-# SOURCE #-} TyCoRep ( Kind, Type, PredType, TyBinder, mkForAllTys ) +import {-# SOURCE #-} TysWiredIn ( runtimeRepTyCon, constraintKind + , vecCountTyCon, vecElemTyCon, liftedTypeKind ) import {-# SOURCE #-} DataCon ( DataCon, dataConExTyVars, dataConFieldLabels ) import Binary @@ -127,6 +132,7 @@ import FieldLabel import Constants import Util import Unique( tyConRepNameUnique, dataConRepNameUnique ) +import UniqSet import Module import qualified Data.Data as Data @@ -322,12 +328,13 @@ it's worth noting that (~#)'s parameters are at role N. Promoted data constructors' type arguments are at role R. All kind arguments are at role N. -Note [Unboxed tuple levity vars] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The contents of an unboxed tuple may be boxed or unboxed. Accordingly, -the kind of the unboxed tuple constructor is sort-polymorphic. For example, +Note [Unboxed tuple RuntimeRep vars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The contents of an unboxed tuple may have any representation. Accordingly, +the kind of the unboxed tuple constructor is runtime-representation +polymorphic. For example, - (#,#) :: forall (v :: Levity) (w :: Levity). TYPE v -> TYPE w -> # + (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep). TYPE q -> TYPE r -> # These extra tyvars (v and w) cause some delicate processing around tuples, where we used to be able to assume that the tycon arity and the @@ -390,6 +397,13 @@ data TyCon tyConName :: Name, -- ^ Name of the constructor + tyConBinders :: [TyBinder], -- ^ The TyBinders for this TyCon's kind. + -- length tyConBinders == tyConArity. + -- This is a cached value and is redundant with + -- the tyConKind. + + tyConResKind :: Kind, -- ^ Cached result kind + tyConKind :: Kind, -- ^ Kind of this TyCon (full kind, not just -- the return kind) @@ -420,6 +434,13 @@ data TyCon tyConName :: Name, -- ^ Name of the constructor + tyConBinders :: [TyBinder], -- ^ The TyBinders for this TyCon's kind. + -- length tyConBinders == tyConArity. + -- This is a cached value and is redundant with + -- the tyConKind. + + tyConResKind :: Kind, -- ^ Cached result kind + tyConKind :: Kind, -- ^ Kind of this TyCon (full kind, not just -- the return kind) @@ -483,6 +504,13 @@ data TyCon tyConName :: Name, -- ^ Name of the constructor + tyConBinders :: [TyBinder], -- ^ The TyBinders for this TyCon's kind. + -- length tyConBinders == tyConArity. + -- This is a cached value and is redundant with + -- the tyConKind. + + tyConResKind :: Kind, -- ^ Cached result kind. + tyConKind :: Kind, -- ^ Kind of this TyCon (full kind, not just -- the return kind) @@ -511,6 +539,13 @@ data TyCon tyConName :: Name, -- ^ Name of the constructor + tyConBinders :: [TyBinder], -- ^ The TyBinders for this TyCon's kind. + -- length tyConBinders == tyConArity. + -- This is a cached value and is redundant with + -- the tyConKind. + + tyConResKind :: Kind, -- ^ Cached result kind + tyConKind :: Kind, -- ^ Kind of this TyCon (full kind, not just -- the return kind) @@ -558,6 +593,13 @@ data TyCon tyConName :: Name, -- ^ Name of the constructor + tyConBinders :: [TyBinder], -- ^ The TyBinders for this TyCon's kind. + -- length tyConBinders == tyConArity. + -- This is a cached value and is redundant with + -- the tyConKind. + + tyConResKind :: Kind, -- ^ Cached result kind + tyConKind :: Kind, -- ^ Kind of this TyCon (full kind, not just -- the return kind) @@ -569,11 +611,6 @@ data TyCon -- This list has the same length as tyConTyVars -- See also Note [TyCon Role signatures] - primTyConRep :: PrimRep,-- ^ Many primitive tycons are unboxed, but - -- some are boxed (represented by - -- pointers). This 'PrimRep' holds that - -- information. Only relevant if tyConKind = # - isUnlifted :: Bool, -- ^ Most primitive tycons are unlifted (may -- not contain bottom) but other are lifted, -- e.g. @RealWorld@ @@ -585,13 +622,19 @@ data TyCon -- | Represents promoted data constructor. | PromotedDataCon { -- See Note [Promoted data constructors] - tyConUnique :: Unique, -- ^ Same Unique as the data constructor - tyConName :: Name, -- ^ Same Name as the data constructor - tyConArity :: Arity, - tyConKind :: Kind, -- ^ Translated type of the data constructor - tcRoles :: [Role], -- ^ Roles: N for kind vars, R for type vars - dataCon :: DataCon,-- ^ Corresponding data constructor - tcRepName :: TyConRepName + tyConUnique :: Unique, -- ^ Same Unique as the data constructor + tyConName :: Name, -- ^ Same Name as the data constructor + tyConArity :: Arity, + tyConBinders :: [TyBinder], -- ^ The TyBinders for this TyCon's kind. + -- length tyConBinders == tyConArity. + -- This is a cached value and is redundant with + -- the tyConKind. + tyConResKind :: Kind, -- ^ Cached result kind + tyConKind :: Kind, -- ^ Type of the data constructor + tcRoles :: [Role], -- ^ Roles: N for kind vars, R for type vars + dataCon :: DataCon,-- ^ Corresponding data constructor + tcRepName :: TyConRepName, + promDcRepInfo :: RuntimeRepInfo -- ^ See comments with 'RuntimeRepInfo' } -- | These exist only during a recursive type/class type-checking knot. @@ -600,6 +643,12 @@ data TyCon tyConName :: Name, tyConUnsat :: Bool, -- ^ can this tycon be unsaturated? tyConArity :: Arity, + tyConBinders :: [TyBinder], -- ^ The TyBinders for this TyCon's kind. + -- length tyConBinders == tyConArity. + -- This is a cached value and is redundant with + -- the tyConKind. + tyConResKind :: Kind, -- ^ Cached result kind + tyConKind :: Kind } deriving Typeable @@ -668,6 +717,19 @@ data AlgTyConRhs -- again check Trac #1072. } +-- | Some promoted datacons signify extra info relevant to GHC. For example, +-- the @IntRep@ constructor of @RuntimeRep@ corresponds to the 'IntRep' +-- constructor of 'PrimRep'. This data structure allows us to store this +-- information right in the 'TyCon'. The other approach would be to look +-- up things like @RuntimeRep@'s @PrimRep@ by known-key every time. +data RuntimeRepInfo + = NoRRI -- ^ an ordinary promoted data con + | 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@ + | VecElem PrimElemRep -- ^ A constructor of @VecElem@ + -- | Extract those 'DataCon's that we are able to learn about. Note -- that visibility in this sense does not correspond to visibility in -- the context of any particular user program! @@ -1132,14 +1194,16 @@ So we compromise, and move their Kind calculation to the call site. -- | Given the name of the function type constructor and it's kind, create the -- corresponding 'TyCon'. It is reccomended to use 'TyCoRep.funTyCon' if you want -- this functionality -mkFunTyCon :: Name -> Kind -> Name -> TyCon -mkFunTyCon name kind rep_nm +mkFunTyCon :: Name -> [TyBinder] -> Name -> TyCon +mkFunTyCon name binders rep_nm = FunTyCon { - tyConUnique = nameUnique name, - tyConName = name, - tyConKind = kind, - tyConArity = 2, - tcRepName = rep_nm + tyConUnique = nameUnique name, + tyConName = name, + tyConBinders = binders, + tyConResKind = liftedTypeKind, + tyConKind = mkForAllTys binders liftedTypeKind, + tyConArity = 2, + tcRepName = rep_nm } -- | This is the making of an algebraic 'TyCon'. Notably, you have to @@ -1147,7 +1211,8 @@ mkFunTyCon name kind rep_nm -- type constructor - you can get hold of it easily (see Generics -- module) mkAlgTyCon :: Name - -> Kind -- ^ Kind of the resulting 'TyCon' + -> [TyBinder] -- ^ Binders of the resulting 'TyCon' + -> Kind -- ^ Result kind -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars'. -- Arity is inferred from the length of this -- list @@ -1161,11 +1226,13 @@ mkAlgTyCon :: Name -> RecFlag -- ^ Is the 'TyCon' recursive? -> Bool -- ^ Was the 'TyCon' declared with GADT syntax? -> TyCon -mkAlgTyCon name kind tyvars roles cType stupid rhs parent is_rec gadt_syn +mkAlgTyCon name binders res_kind tyvars roles cType stupid rhs parent is_rec gadt_syn = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, - tyConKind = kind, + tyConBinders = binders, + tyConResKind = res_kind, + tyConKind = mkForAllTys binders res_kind, tyConArity = length tyvars, tyConTyVars = tyvars, tcRoles = roles, @@ -1179,26 +1246,30 @@ mkAlgTyCon name kind tyvars roles cType stupid rhs parent is_rec gadt_syn } -- | Simpler specialization of 'mkAlgTyCon' for classes -mkClassTyCon :: Name -> Kind -> [TyVar] -> [Role] -> AlgTyConRhs -> Class +mkClassTyCon :: Name -> [TyBinder] + -> [TyVar] -> [Role] -> AlgTyConRhs -> Class -> RecFlag -> Name -> TyCon -mkClassTyCon name kind tyvars roles rhs clas is_rec tc_rep_name - = mkAlgTyCon name kind tyvars roles Nothing [] rhs +mkClassTyCon name binders tyvars roles rhs clas is_rec tc_rep_name + = mkAlgTyCon name binders constraintKind tyvars roles Nothing [] rhs (ClassTyCon clas tc_rep_name) is_rec False mkTupleTyCon :: Name - -> Kind -- ^ Kind of the resulting 'TyCon' + -> [TyBinder] + -> Kind -- ^ Result kind of the 'TyCon' -> Arity -- ^ Arity of the tuple -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars' -> DataCon -> TupleSort -- ^ Whether the tuple is boxed or unboxed -> AlgTyConFlav -> TyCon -mkTupleTyCon name kind arity tyvars con sort parent +mkTupleTyCon name binders res_kind arity tyvars con sort parent = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, - tyConKind = kind, + tyConBinders = binders, + tyConResKind = res_kind, + tyConKind = mkForAllTys binders res_kind, tyConArity = arity, tyConTyVars = tyvars, tcRoles = replicate arity Representational, @@ -1218,75 +1289,91 @@ mkTupleTyCon name kind arity tyvars con sort parent -- TcErrors sometimes calls typeKind. -- See also Note [Kind checking recursive type and class declarations] -- in TcTyClsDecls. -mkTcTyCon :: Name -> Kind -> Bool -- ^ Can this be unsaturated? - -> Arity +mkTcTyCon :: Name -> [TyBinder] -> Kind -- ^ /result/ kind only + -> Bool -- ^ Can this be unsaturated? -> TyCon -mkTcTyCon name kind unsat arity +mkTcTyCon name binders res_kind unsat = TcTyCon { tyConUnique = getUnique name , tyConName = name - , tyConKind = kind + , tyConBinders = binders + , tyConResKind = res_kind + , tyConKind = mkForAllTys binders res_kind , tyConUnsat = unsat - , tyConArity = arity } + , tyConArity = length binders } -- | Create an unlifted primitive 'TyCon', such as @Int#@ -mkPrimTyCon :: Name -> Kind -> [Role] -> PrimRep -> TyCon -mkPrimTyCon name kind roles rep - = mkPrimTyCon' name kind roles rep True (Just $ mkPrelTyConRepName name) +mkPrimTyCon :: Name -> [TyBinder] + -> Kind -- ^ /result/ kind + -> [Role] -> TyCon +mkPrimTyCon name binders res_kind roles + = mkPrimTyCon' name binders res_kind roles True (Just $ mkPrelTyConRepName name) -- | Kind constructors -mkKindTyCon :: Name -> Kind -> [Role] -> Name -> TyCon -mkKindTyCon name kind roles rep_nm +mkKindTyCon :: Name -> [TyBinder] + -> Kind -- ^ /result/ kind + -> [Role] -> Name -> TyCon +mkKindTyCon name binders res_kind roles rep_nm = tc where - tc = mkPrimTyCon' name kind roles PtrRep False (Just rep_nm) - -- PtrRep because kinds have kind *. + tc = mkPrimTyCon' name binders res_kind roles False (Just rep_nm) -- | Create a lifted primitive 'TyCon' such as @RealWorld@ -mkLiftedPrimTyCon :: Name -> Kind -> [Role] -> PrimRep -> TyCon -mkLiftedPrimTyCon name kind roles rep - = mkPrimTyCon' name kind roles rep False Nothing - -mkPrimTyCon' :: Name -> Kind -> [Role] -> PrimRep +mkLiftedPrimTyCon :: Name -> [TyBinder] + -> Kind -- ^ /result/ kind + -> [Role] -> TyCon +mkLiftedPrimTyCon name binders res_kind roles + = mkPrimTyCon' name binders res_kind roles False Nothing + +mkPrimTyCon' :: Name -> [TyBinder] + -> Kind -- ^ /result/ kind + -> [Role] -> Bool -> Maybe TyConRepName -> TyCon -mkPrimTyCon' name kind roles rep is_unlifted rep_nm +mkPrimTyCon' name binders res_kind roles is_unlifted rep_nm = PrimTyCon { tyConName = name, tyConUnique = nameUnique name, - tyConKind = kind, + tyConBinders = binders, + tyConResKind = res_kind, + tyConKind = mkForAllTys binders res_kind, tyConArity = length roles, tcRoles = roles, - primTyConRep = rep, isUnlifted = is_unlifted, primRepName = rep_nm } -- | Create a type synonym 'TyCon' -mkSynonymTyCon :: Name -> Kind -> [TyVar] -> [Role] -> Type -> TyCon -mkSynonymTyCon name kind tyvars roles rhs +mkSynonymTyCon :: Name -> [TyBinder] -> Kind -- ^ /result/ kind + -> [TyVar] -> [Role] -> Type -> TyCon +mkSynonymTyCon name binders res_kind tyvars roles rhs = SynonymTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConKind = kind, - tyConArity = length tyvars, - tyConTyVars = tyvars, - tcRoles = roles, - synTcRhs = rhs + tyConName = name, + tyConUnique = nameUnique name, + tyConBinders = binders, + tyConResKind = res_kind, + tyConKind = mkForAllTys binders res_kind, + tyConArity = length tyvars, + tyConTyVars = tyvars, + tcRoles = roles, + synTcRhs = rhs } -- | Create a type family 'TyCon' -mkFamilyTyCon:: Name -> Kind -> [TyVar] -> Maybe Name -> FamTyConFlav - -> Maybe Class -> Injectivity -> TyCon -mkFamilyTyCon name kind tyvars resVar flav parent inj +mkFamilyTyCon :: Name -> [TyBinder] -> Kind -- ^ /result/ kind + -> [TyVar] -> Maybe Name -> FamTyConFlav + -> Maybe Class -> Injectivity -> TyCon +mkFamilyTyCon name binders res_kind tyvars resVar flav parent inj = FamilyTyCon - { tyConUnique = nameUnique name - , tyConName = name - , tyConKind = kind - , tyConArity = length tyvars - , tyConTyVars = tyvars - , famTcResVar = resVar - , famTcFlav = flav - , famTcParent = parent - , famTcInj = inj + { tyConUnique = nameUnique name + , tyConName = name + , tyConBinders = binders + , tyConResKind = res_kind + , tyConKind = mkForAllTys binders res_kind + , tyConArity = length tyvars + , tyConTyVars = tyvars + , famTcResVar = resVar + , famTcFlav = flav + , famTcParent = parent + , famTcInj = inj } @@ -1294,16 +1381,20 @@ mkFamilyTyCon name kind tyvars resVar flav parent inj -- Somewhat dodgily, we give it the same Name -- as the data constructor itself; when we pretty-print -- the TyCon we add a quote; see the Outputable TyCon instance -mkPromotedDataCon :: DataCon -> Name -> TyConRepName -> Kind -> [Role] -> TyCon -mkPromotedDataCon con name rep_name kind roles +mkPromotedDataCon :: DataCon -> Name -> TyConRepName -> [TyBinder] -> Kind -> [Role] + -> RuntimeRepInfo -> TyCon +mkPromotedDataCon con name rep_name binders res_kind roles rep_info = PromotedDataCon { - tyConUnique = nameUnique name, - tyConName = name, - tyConArity = arity, - tcRoles = roles, - tyConKind = kind, - dataCon = con, - tcRepName = rep_name + tyConUnique = nameUnique name, + tyConName = name, + tyConArity = arity, + tcRoles = roles, + tyConBinders = binders, + tyConResKind = res_kind, + tyConKind = mkForAllTys binders res_kind, + dataCon = con, + tcRepName = rep_name, + promDcRepInfo = rep_info } where arity = length roles @@ -1321,16 +1412,8 @@ isAbstractTyCon _ = False -- Used when recovering from errors makeTyConAbstract :: TyCon -> TyCon makeTyConAbstract tc - = PrimTyCon { tyConName = name, - tyConUnique = nameUnique name, - tyConKind = tyConKind tc, - tyConArity = tyConArity tc, - tcRoles = tyConRoles tc, - primTyConRep = PtrRep, - isUnlifted = False, - primRepName = Nothing } - where - name = tyConName tc + = mkTcTyCon (tyConName tc) (tyConBinders tc) (tyConResKind tc) + (mightBeUnsaturatedTyCon tc) -- | Does this 'TyCon' represent something that cannot be defined in Haskell? isPrimTyCon :: TyCon -> Bool @@ -1642,12 +1725,18 @@ isPromotedDataCon_maybe _ = Nothing -- | Is this tycon really meant for use at the kind level? That is, -- should it be permitted without -XDataKinds? isKindTyCon :: TyCon -> Bool -isKindTyCon tc = isLiftedTypeKindTyConName (tyConName tc) || - tc `hasKey` constraintKindTyConKey || - tc `hasKey` tYPETyConKey || - tc `hasKey` levityTyConKey || - tc `hasKey` liftedDataConKey || - tc `hasKey` unliftedDataConKey +isKindTyCon tc = getUnique tc `elementOfUniqSet` kindTyConKeys + +-- | These TyCons should be allowed at the kind level, even without +-- -XDataKinds. +kindTyConKeys :: UniqSet Unique +kindTyConKeys = unionManyUniqSets + ( mkUniqSet [ liftedTypeKindTyConKey, starKindTyConKey, unicodeStarKindTyConKey + , constraintKindTyConKey, tYPETyConKey ] + : map (mkUniqSet . tycon_with_datacons) [ runtimeRepTyCon + , vecCountTyCon, vecElemTyCon ] ) + where + tycon_with_datacons tc = getUnique tc : map getUnique (tyConDataCons tc) isLiftedTypeKindTyConName :: Name -> Bool isLiftedTypeKindTyConName @@ -1855,11 +1944,6 @@ newTyConCo tc = case newTyConCo_maybe tc of Just co -> co Nothing -> pprPanic "newTyConCo" (ppr tc) --- | Find the primitive representation of a 'TyCon' -tyConPrimRep :: TyCon -> PrimRep -tyConPrimRep (PrimTyCon {primTyConRep = rep}) = rep -tyConPrimRep tc = ASSERT(not (isUnboxedTupleTyCon tc)) PtrRep - -- | Find the \"stupid theta\" of the 'TyCon'. A \"stupid theta\" is the context -- to the left of an algebraic type declaration, e.g. @Eq a@ in the declaration -- @data Eq a => T a ...@ @@ -1929,6 +2013,12 @@ tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = DataFamInstTyCon ax _ _ }) = Just ax tyConFamilyCoercion_maybe _ = Nothing +-- | Extract any 'RuntimeRepInfo' from this TyCon +tyConRuntimeRepInfo :: TyCon -> RuntimeRepInfo +tyConRuntimeRepInfo (PromotedDataCon { promDcRepInfo = rri }) = rri +tyConRuntimeRepInfo _ = NoRRI + -- could panic in that second case. But Douglas Adams told me not to. + {- ************************************************************************ * * diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs index 824aa9d752..bca64c2efc 100644 --- a/compiler/types/Type.hs +++ b/compiler/types/Type.hs @@ -41,7 +41,7 @@ module Type ( splitForAllTy_maybe, splitForAllTys, splitForAllTy, splitPiTy_maybe, splitPiTys, splitPiTy, splitNamedPiTys, - mkPiType, mkPiTypes, mkPiTypesPreferFunTy, + mkPiType, mkPiTypes, mkTyBindersPreferAnon, piResultTy, piResultTys, applyTysX, dropForAlls, @@ -58,7 +58,6 @@ module Type ( splitPiTysInvisible, filterOutInvisibleTypes, filterOutInvisibleTyVars, partitionInvisibles, synTyConResKind, - tyConBinders, -- Analyzing types TyCoMapper(..), mapType, mapCoercion, @@ -103,9 +102,9 @@ module Type ( -- (Lifting and boxity) isUnliftedType, isUnboxedTupleType, isAlgType, isClosedAlgType, isPrimitiveType, isStrictType, - isLevityTy, isLevityVar, isLevityKindedTy, - dropLevityArgs, - getLevity, getLevityFromKind, + isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy, + dropRuntimeRepArgs, + getRuntimeRep, getRuntimeRepFromKind, -- * Main data types representing Kinds Kind, @@ -114,7 +113,7 @@ module Type ( typeKind, -- ** Common Kind - liftedTypeKind, unliftedTypeKind, + liftedTypeKind, -- * Type free variables tyCoVarsOfType, tyCoVarsOfTypes, tyCoVarsOfTypeAcc, @@ -143,7 +142,7 @@ module Type ( tyConsOfType, -- * Type representation for the code generator - typePrimRep, typeRepArity, + typePrimRep, typeRepArity, kindPrimRep, tyConPrimRep, -- * Main type substitution data types TvSubstEnv, -- Representation widely visible @@ -310,7 +309,8 @@ coreView (TyConApp tc tys) | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc t coreView _ = Nothing -- | Like 'coreView', but it also "expands" @Constraint@ to become --- @TYPE Lifted@. +-- @TYPE PtrRepLifted@. +{-# INLINE coreViewOneStarKind #-} coreViewOneStarKind :: Type -> Maybe Type coreViewOneStarKind ty | Just ty' <- coreView ty = Just ty' @@ -1077,27 +1077,28 @@ mkCastTy ty co = -- NB: don't check if the coercion "from" type matches here; = split_apps (t2:args) t1 co split_apps args (TyConApp tc tc_args) co | mightBeUnsaturatedTyCon tc - = affix_co (tyConKind tc) (mkTyConTy tc) (tc_args `chkAppend` args) co + = affix_co (tyConBinders tc) (mkTyConTy tc) (tc_args `chkAppend` args) co | otherwise -- not decomposable... but it may still be oversaturated = let (non_decomp_args, decomp_args) = splitAt (tyConArity tc) tc_args saturated_tc = mkTyConApp tc non_decomp_args in - affix_co (typeKind saturated_tc) saturated_tc (decomp_args `chkAppend` args) co + affix_co (fst $ splitPiTys $ typeKind saturated_tc) + saturated_tc (decomp_args `chkAppend` args) co split_apps args (ForAllTy (Anon arg) res) co - = affix_co (tyConKind funTyCon) (mkTyConTy funTyCon) + = affix_co (tyConBinders funTyCon) (mkTyConTy funTyCon) (arg : res : args) co split_apps args ty co - = affix_co (typeKind ty) ty args co + = affix_co (fst $ splitPiTys $ typeKind ty) + ty args co -- having broken everything apart, this figures out the point at which there -- are no more dependent quantifications, and puts the cast there affix_co _ ty [] co = no_double_casts ty co - affix_co kind ty args co + affix_co bndrs ty args co -- if kind contains any dependent quantifications, we can't push. -- apply arguments until it doesn't - = let (bndrs, _inner_ki) = splitPiTys kind - (no_dep_bndrs, some_dep_bndrs) = spanEnd isAnonBinder bndrs + = let (no_dep_bndrs, some_dep_bndrs) = spanEnd isAnonBinder bndrs (some_dep_args, rest_args) = splitAtList some_dep_bndrs args dep_subst = zipTyBinderSubst some_dep_bndrs some_dep_args used_no_dep_bndrs = takeList rest_args no_dep_bndrs @@ -1212,10 +1213,10 @@ repType ty | isUnboxedTupleTyCon tc = if null tys then UnaryRep voidPrimTy -- See Note [Nullary unboxed tuple] - else UbxTupleRep (concatMap (flattenRepType . go rec_nts) non_levity_tys) + else UbxTupleRep (concatMap (flattenRepType . go rec_nts) non_rr_tys) where - -- See Note [Unboxed tuple levity vars] in TyCon - non_levity_tys = dropLevityArgs tys + -- See Note [Unboxed tuple RuntimeRep vars] in TyCon + non_rr_tys = dropRuntimeRepArgs tys go rec_nts (CastTy ty _) = go rec_nts ty @@ -1230,16 +1231,31 @@ repType ty -- | Discovers the primitive representation of a more abstract 'UnaryType' typePrimRep :: UnaryType -> PrimRep -typePrimRep ty - = case repType ty of - UbxTupleRep _ -> pprPanic "typePrimRep: UbxTupleRep" (ppr ty) - UnaryRep rep -> go rep - where go (TyConApp tc _) = tyConPrimRep tc - go (ForAllTy _ _) = PtrRep - go (AppTy _ _) = PtrRep -- See Note [AppTy rep] - go (TyVarTy _) = PtrRep - go (CastTy ty _) = go ty - go _ = pprPanic "typePrimRep: UnaryRep" (ppr ty) +typePrimRep ty = kindPrimRep (typeKind ty) + +-- | Find the primitive representation of a 'TyCon'. Defined here to +-- avoid module loops. Call this only on unlifted tycons. +tyConPrimRep :: TyCon -> PrimRep +tyConPrimRep tc = kindPrimRep res_kind + where + res_kind = tyConResKind tc + +-- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep' of values +-- of types of this kind. +kindPrimRep :: Kind -> PrimRep +kindPrimRep ki | Just ki' <- coreViewOneStarKind ki = kindPrimRep ki' +kindPrimRep (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) +kindPrimRep ki = WARN( True + , text "kindPrimRep defaulting to PtrRep on" <+> ppr ki ) + PtrRep -- this can happen legitimately for, e.g., Any typeRepArity :: Arity -> Type -> RepArity typeRepArity 0 _ = 0 @@ -1250,7 +1266,8 @@ typeRepArity n ty = case repType ty of isVoidTy :: Type -> Bool -- True if the type has zero width isVoidTy ty = case repType ty of - UnaryRep (TyConApp tc _) -> isVoidRep (tyConPrimRep tc) + UnaryRep (TyConApp tc _) -> isUnliftedTyCon tc && + isVoidRep (tyConPrimRep tc) _ -> False {- @@ -1274,10 +1291,6 @@ mkNamedForAllTy :: TyVar -> VisibilityFlag -> Type -> Type mkNamedForAllTy tv vis = ASSERT( isTyVar tv ) ForAllTy (Named tv vis) --- | Wraps foralls over the type using the provided 'TyVar's from left to right -mkForAllTys :: [TyBinder] -> Type -> Type -mkForAllTys tyvars ty = foldr ForAllTy ty tyvars - -- | Like mkForAllTys, but assumes all variables are dependent and invisible, -- a common case mkInvForAllTys :: [TyVar] -> Type -> Type @@ -1309,23 +1322,23 @@ mkPiType v ty mkPiTypes vs ty = foldr mkPiType ty vs --- | Given a list of type-level vars, makes ForAllTys, preferring +-- | Given a list of type-level vars and a result type, makes TyBinders, preferring -- anonymous binders if the variable is, in fact, not dependent. -- All binders are /visible/. -mkPiTypesPreferFunTy :: [TyVar] -> Type -> Type -mkPiTypesPreferFunTy vars inner_ty = fst $ go vars inner_ty +mkTyBindersPreferAnon :: [TyVar] -> Type -> [TyBinder] +mkTyBindersPreferAnon vars inner_ty = fst $ go vars inner_ty where - go :: [TyVar] -> Type -> (Type, VarSet) -- also returns the free vars - go [] ty = (ty, tyCoVarsOfType ty) - go (v:vs) ty | v `elemVarSet` fvs - = ( mkForAllTy (Named v Visible) qty + go :: [TyVar] -> Type -> ([TyBinder], VarSet) -- also returns the free vars + go [] ty = ([], tyCoVarsOfType ty) + go (v:vs) ty | v `elemVarSet` fvs + = ( Named v Visible : binders , fvs `delVarSet` v `unionVarSet` kind_vars ) | otherwise - = ( mkForAllTy (Anon (tyVarKind v)) qty + = ( Anon (tyVarKind v) : binders , fvs `unionVarSet` kind_vars ) where - (qty, fvs) = go vs ty - kind_vars = tyCoVarsOfType $ tyVarKind v + (binders, fvs) = go vs ty + kind_vars = tyCoVarsOfType $ tyVarKind v -- | Take a ForAllTy apart, returning the list of tyvars and the result type. -- This always succeeds, even if it returns only an empty list. Note that the @@ -1454,9 +1467,6 @@ splitPiTysInvisible ty = split ty ty [] split orig_ty _ bndrs = (reverse bndrs, orig_ty) -tyConBinders :: TyCon -> [TyBinder] -tyConBinders = fst . splitPiTys . tyConKind - applyTysX :: [TyVar] -> Type -> [Type] -> Type -- applyTyxX beta-reduces (/\tvs. body_ty) arg_tys -- Assumes that (/\tvs. body_ty) is closed @@ -1917,25 +1927,26 @@ isUnliftedType (ForAllTy (Named {}) ty) = isUnliftedType ty isUnliftedType (TyConApp tc _) = isUnliftedTyCon tc isUnliftedType _ = False --- | Extract the levity classifier of a type. Panics if this is not possible. -getLevity :: String -- ^ Printed in case of an error - -> Type -> Type -getLevity err ty = getLevityFromKind err (typeKind ty) +-- | Extract the RuntimeRep classifier of a type. Panics if this is not possible. +getRuntimeRep :: String -- ^ Printed in case of an error + -> Type -> Type +getRuntimeRep err ty = getRuntimeRepFromKind err (typeKind ty) --- | Extract the levity classifier of a type from its kind. --- For example, getLevityFromKind * = Lifted; getLevityFromKind # = Unlifted. +-- | Extract the RuntimeRep classifier of a type from its kind. +-- For example, getRuntimeRepFromKind * = PtrRepLifted; +-- getRuntimeRepFromKind # = PtrRepUnlifted. -- Panics if this is not possible. -getLevityFromKind :: String -- ^ Printed in case of an error - -> Type -> Type -getLevityFromKind err = go +getRuntimeRepFromKind :: 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 - go k = pprPanic "getLevity" (text err $$ - ppr k <+> dcolon <+> ppr (typeKind k)) + go k = pprPanic "getRuntimeRep" (text err $$ + ppr k <+> dcolon <+> ppr (typeKind k)) isUnboxedTupleType :: Type -> Bool isUnboxedTupleType ty = case tyConAppTyCon_maybe ty of @@ -2065,11 +2076,17 @@ cmpTypes ts1 ts2 = cmpTypesX rn_env ts1 ts2 cmpTypeX :: RnEnv2 -> Type -> Type -> Ordering -- Main workhorse -- See Note [Non-trivial definitional equality] in TyCoRep -cmpTypeX env orig_t1 orig_t2 = go env k1 k2 `thenCmp` go env orig_t1 orig_t2 +cmpTypeX env orig_t1 orig_t2 + = go env orig_t1 orig_t2 `thenCmp` go env k1 k2 + -- NB: this ordering appears to be faster than the other where k1 = typeKind orig_t1 k2 = typeKind orig_t2 + -- short-cut to handle comparing * against *. + -- appears to have a roughly 1% improvement in compile times + go _ (TyConApp tc1 []) (TyConApp tc2 []) | tc1 == tc2 = EQ + go env t1 t2 | Just t1' <- coreViewOneStarKind t1 = go env t1' t2 go env t1 t2 | Just t2' <- coreViewOneStarKind t2 = go env t1 t2' diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs index 8cafbfb4f1..ff0f45f725 100644 --- a/compiler/utils/Util.hs +++ b/compiler/utils/Util.hs @@ -14,6 +14,8 @@ module Util ( zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, zipLazy, stretchZipWith, zipWithAndUnzip, + zipWithLazy, zipWith3Lazy, + filterByList, filterByLists, partitionByList, unzipWith, @@ -322,6 +324,20 @@ zipLazy :: [a] -> [b] -> [(a,b)] zipLazy [] _ = [] zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys +-- | 'zipWithLazy' is like 'zipWith' but is lazy in the second list. +-- The length of the output is always the same as the length of the first +-- list. +zipWithLazy :: (a -> b -> c) -> [a] -> [b] -> [c] +zipWithLazy _ [] _ = [] +zipWithLazy f (a:as) ~(b:bs) = f a b : zipWithLazy f as bs + +-- | 'zipWith3Lazy' is like 'zipWith3' but is lazy in the second and third lists. +-- The length of the output is always the same as the length of the first +-- list. +zipWith3Lazy :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] +zipWith3Lazy _ [] _ _ = [] +zipWith3Lazy f (a:as) ~(b:bs) ~(c:cs) = f a b c : zipWith3Lazy f as bs cs + -- | 'filterByList' takes a list of Bools and a list of some elements and -- filters out these elements for which the corresponding value in the list of -- Bools is False. This function does not check whether the lists have equal diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs index 5f283c6d3a..9daa16a170 100644 --- a/compiler/vectorise/Vectorise/Exp.hs +++ b/compiler/vectorise/Vectorise/Exp.hs @@ -360,7 +360,7 @@ vectExpr (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType ty)) err) | v == pAT_ERROR_ID = do { (vty, lty) <- vectAndLiftType ty - ; return (mkCoreApps (Var v) [Type (getLevity "vectExpr" vty), Type vty, err'], mkCoreApps (Var v) [Type lty, err']) + ; return (mkCoreApps (Var v) [Type (getRuntimeRep "vectExpr" vty), Type vty, err'], mkCoreApps (Var v) [Type lty, err']) } where err' = deAnnotate err diff --git a/compiler/vectorise/Vectorise/Generic/PData.hs b/compiler/vectorise/Vectorise/Generic/PData.hs index a8bffbe962..4f3112850d 100644 --- a/compiler/vectorise/Vectorise/Generic/PData.hs +++ b/compiler/vectorise/Vectorise/Generic/PData.hs @@ -51,7 +51,8 @@ buildDataFamInst name' fam_tc vect_tc rhs rep_ty = mkTyConApp rep_tc tys' pat_tys = [mkTyConApp vect_tc tys'] rep_tc = mkAlgTyCon name' - (mkPiTypesPreferFunTy tyvars' liftedTypeKind) + (mkTyBindersPreferAnon tyvars' liftedTypeKind) + liftedTypeKind tyvars' (map (const Nominal) tyvars') Nothing diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs index 7b00a5c1ef..0bcdf0c4a8 100644 --- a/compiler/vectorise/Vectorise/Type/Env.hs +++ b/compiler/vectorise/Vectorise/Type/Env.hs @@ -360,7 +360,7 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls origName = tyConName origTyCon vectName = tyConName vectTyCon - mkSyn canonName ty = mkSynonymTyCon canonName (typeKind ty) [] [] ty + mkSyn canonName ty = mkSynonymTyCon canonName [] (typeKind ty) [] [] ty defDataCons | isAbstract = return () diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs index 03e7d27d0e..4847aa87f1 100644 --- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs +++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs @@ -64,7 +64,7 @@ vectTyConDecl tycon name' (tyConTyVars tycon) -- keep original type vars (map (const Nominal) (tyConRoles tycon)) -- all role are N for safety theta' -- superclasses - (tyConKind tycon) -- keep original kind + (tyConBinders tycon) -- keep original kind (snd . classTvsFds $ cls) -- keep the original functional dependencies [] -- no associated types (for the moment) methods' -- method info @@ -103,7 +103,8 @@ vectTyConDecl tycon name' ; tc_rep_name <- mkDerivedName mkTyConRepOcc name' ; return $ mkAlgTyCon name' -- new name - (tyConKind tycon) -- keep original kind + (tyConBinders tycon) + (tyConResKind tycon) -- keep original kind (tyConTyVars tycon) -- keep original type vars (map (const Nominal) (tyConRoles tycon)) -- all roles are N for safety Nothing diff --git a/libraries/base/Data/Data.hs b/libraries/base/Data/Data.hs index 88191c1011..cc94bac30f 100644 --- a/libraries/base/Data/Data.hs +++ b/libraries/base/Data/Data.hs @@ -114,7 +114,7 @@ import Data.Monoid import Data.Ord import Data.Typeable import Data.Version( Version(..) ) -import GHC.Base hiding (Any) +import GHC.Base hiding (Any, IntRep, FloatRep) import GHC.List import GHC.Num import GHC.Read diff --git a/libraries/base/Data/Typeable/Internal.hs b/libraries/base/Data/Typeable/Internal.hs index efec62f7d8..87e5c88c76 100644 --- a/libraries/base/Data/Typeable/Internal.hs +++ b/libraries/base/Data/Typeable/Internal.hs @@ -10,6 +10,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeApplications #-} ----------------------------------------------------------------------------- -- | @@ -249,18 +250,6 @@ tyConOf = typeRepTyCon . typeRep tcFun :: TyCon tcFun = tyConOf (Proxy :: Proxy (Int -> Int)) -tcList :: TyCon -tcList = tyConOf (Proxy :: Proxy []) - -tcTYPE :: TyCon -tcTYPE = tyConOf (Proxy :: Proxy TYPE) - -tc'Lifted :: TyCon -tc'Lifted = tyConOf (Proxy :: Proxy 'Lifted) - -tc'Unlifted :: TyCon -tc'Unlifted = tyConOf (Proxy :: Proxy 'Unlifted) - -- | Adds a TypeRep argument to a TypeRep. mkAppTy :: TypeRep -> TypeRep -> TypeRep {-# INLINE mkAppTy #-} @@ -364,10 +353,19 @@ instance Show TypeRep where showsPrec p (TypeRep _ tycon kinds tys) = case tys of [] -> showsPrec p tycon - [x@(TypeRep _ argCon _ _)] + [x] | tycon == tcList -> showChar '[' . shows x . showChar ']' - | tycon == tcTYPE && argCon == tc'Lifted -> showChar '*' - | tycon == tcTYPE && argCon == tc'Unlifted -> showChar '#' + where + tcList = tyConOf @[] Proxy + [TypeRep _ ptrRepCon _ []] + | tycon == tcTYPE && ptrRepCon == tc'PtrRepLifted + -> showChar '*' + | tycon == tcTYPE && ptrRepCon == tc'PtrRepUnlifted + -> showChar '#' + where + tcTYPE = tyConOf @TYPE Proxy + tc'PtrRepLifted = tyConOf @'PtrRepLifted Proxy + tc'PtrRepUnlifted = tyConOf @'PtrRepUnlifted Proxy [a,r] | tycon == tcFun -> showParen (p > 8) $ showsPrec 9 a . showString " -> " . diff --git a/libraries/base/GHC/Err.hs b/libraries/base/GHC/Err.hs index 88b9c39898..4231fcefa5 100644 --- a/libraries/base/GHC/Err.hs +++ b/libraries/base/GHC/Err.hs @@ -24,7 +24,7 @@ module GHC.Err( absentErr, error, errorWithoutStackTrace, undefined ) where import GHC.CString () -import GHC.Types (Char, Levity) +import GHC.Types (Char, RuntimeRep) import GHC.Stack.Types import GHC.Prim import GHC.Integer () -- Make sure Integer is compiled first @@ -33,7 +33,7 @@ import GHC.Integer () -- Make sure Integer is compiled first import {-# SOURCE #-} GHC.Exception( errorCallWithCallStackException ) -- | 'error' stops execution and displays an error message. -error :: forall (v :: Levity). forall (a :: TYPE v). +error :: forall (r :: RuntimeRep). forall (a :: TYPE r). HasCallStack => [Char] -> a error s = raise# (errorCallWithCallStackException s ?callStack) -- Bleh, we should be using 'GHC.Stack.callStack' instead of @@ -44,7 +44,7 @@ error s = raise# (errorCallWithCallStackException s ?callStack) -- | A variant of 'error' that does not produce a stack trace. -- -- @since 4.9.0.0 -errorWithoutStackTrace :: forall (v :: Levity). forall (a :: TYPE v). +errorWithoutStackTrace :: forall (r :: RuntimeRep). forall (a :: TYPE r). [Char] -> a errorWithoutStackTrace s = -- we don't have withFrozenCallStack yet, so we just inline the definition @@ -74,7 +74,7 @@ errorWithoutStackTrace s = -- It is expected that compilers will recognize this and insert error -- messages which are more appropriate to the context in which 'undefined' -- appears. -undefined :: forall (v :: Levity). forall (a :: TYPE v). +undefined :: forall (r :: RuntimeRep). forall (a :: TYPE r). HasCallStack => a undefined = error "Prelude.undefined" diff --git a/libraries/base/GHC/Exts.hs b/libraries/base/GHC/Exts.hs index 31e70ebd21..21f7bfd8b9 100755 --- a/libraries/base/GHC/Exts.hs +++ b/libraries/base/GHC/Exts.hs @@ -56,8 +56,8 @@ module GHC.Exts -- * Equality type (~~), - -- * Levity polymorphism - GHC.Prim.TYPE, Levity(..), + -- * Representation polymorphism + GHC.Prim.TYPE, RuntimeRep(..), VecCount(..), VecElem(..), -- * Transform comprehensions Down(..), groupWith, sortWith, the, diff --git a/libraries/base/tests/T11334.hs b/libraries/base/tests/T11334.hs index 22864d9c1d..2b4ac56c70 100644 --- a/libraries/base/tests/T11334.hs +++ b/libraries/base/tests/T11334.hs @@ -7,5 +7,5 @@ import GHC.Types main :: IO () main = do print (typeOf (Proxy :: Proxy 'Just)) - print (typeOf (Proxy :: Proxy (TYPE 'Lifted))) - print (typeOf (Proxy :: Proxy (TYPE 'Unlifted))) + print (typeOf (Proxy :: Proxy (TYPE 'PtrRepLifted))) + print (typeOf (Proxy :: Proxy (TYPE 'PtrRepUnlifted))) diff --git a/libraries/ghc-prim/GHC/Types.hs b/libraries/ghc-prim/GHC/Types.hs index 727811bdf4..6f9e09fdfb 100644 --- a/libraries/ghc-prim/GHC/Types.hs +++ b/libraries/ghc-prim/GHC/Types.hs @@ -30,10 +30,11 @@ module GHC.Types ( SPEC(..), Nat, Symbol, type (~~), Coercible, - TYPE, Levity(..), Type, type (*), type (★), Constraint, + TYPE, RuntimeRep(..), Type, type (*), type (★), Constraint, -- The historical type * should ideally be written as -- `type *`, without the parentheses. But that's a true -- pain to parse, and for little gain. + VecCount(..), VecElem(..), -- * Runtime type representation Module(..), TrName(..), TyCon(..) @@ -57,13 +58,13 @@ infixr 5 : data Constraint -- | The kind of types with values. For example @Int :: Type@. -type Type = TYPE 'Lifted +type Type = TYPE 'PtrRepLifted -- | A backward-compatible (pre-GHC 8.0) synonym for 'Type' -type * = TYPE 'Lifted +type * = TYPE 'PtrRepLifted -- | A unicode backward-compatible (pre-GHC 8.0) synonym for 'Type' -type ★ = TYPE 'Lifted +type ★ = TYPE 'PtrRepLifted {- ********************************************************************* * * @@ -330,17 +331,59 @@ you're reading this in 2023 then things went wrong). See #8326. -- loops should be aggressively specialized. data SPEC = SPEC | SPEC2 --- | GHC divides all proper types (that is, types that can perhaps be --- inhabited, as distinct from type constructors or type-level data) --- into two worlds: lifted types and unlifted types. For example, --- @Int@ is lifted while @Int#@ is unlifted. Certain operations need --- to be polymorphic in this distinction. A classic example is 'unsafeCoerce#', --- which needs to be able to coerce between lifted and unlifted types. --- To achieve this, we use kind polymorphism: lifted types have kind --- @TYPE Lifted@ and unlifted ones have kind @TYPE Unlifted@. 'Levity' --- is the kind of 'Lifted' and 'Unlifted'. @*@ is a synonym for @TYPE Lifted@ --- and @#@ is a synonym for @TYPE Unlifted@. -data Levity = Lifted | Unlifted + +{- ********************************************************************* +* * + RuntimeRep +* * +********************************************************************* -} + + +-- | GHC maintains a property that the kind of all inhabited types +-- (as distinct from type constructors or type-level data) tells us +-- the runtime representation of values of that type. This datatype +-- encodes the choice of runtime value. +-- Note that 'TYPE' is parameterised by 'RuntimeRep'; this is precisely +-- what we mean by the fact that a type's kind encodes the runtime +-- representation. +-- +-- For boxed values (that is, values that are represented by a pointer), +-- 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 + | IntRep -- ^ signed, word-sized value + | WordRep -- ^ unsigned, word-sized value + | Int64Rep -- ^ signed, 64-bit value (on 32-bit only) + | Word64Rep -- ^ unsigned, 64-bit value (on 32-bit only) + | 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 + +-- See also Note [Wiring in RuntimeRep] in TysWiredIn + +-- | Length of a SIMD vector type +data VecCount = Vec2 + | Vec4 + | Vec8 + | Vec16 + | Vec32 + | Vec64 + +-- | Element of a SIMD vector type +data VecElem = Int8ElemRep + | Int16ElemRep + | Int32ElemRep + | Int64ElemRep + | Word8ElemRep + | Word16ElemRep + | Word32ElemRep + | Word64ElemRep + | FloatElemRep + | DoubleElemRep {- ********************************************************************* * * diff --git a/testsuite/tests/dependent/should_compile/T11405.hs b/testsuite/tests/dependent/should_compile/T11405.hs index f80d994dc7..cdb713f118 100644 --- a/testsuite/tests/dependent/should_compile/T11405.hs +++ b/testsuite/tests/dependent/should_compile/T11405.hs @@ -5,5 +5,5 @@ module T11405 where import GHC.Exts import GHC.Stack -x :: forall (v :: Levity) (a :: TYPE v). (?callStack :: CallStack) => a +x :: forall (v :: RuntimeRep) (a :: TYPE v). (?callStack :: CallStack) => a x = undefined diff --git a/testsuite/tests/dependent/should_fail/BadTelescope4.stderr b/testsuite/tests/dependent/should_fail/BadTelescope4.stderr index 158aec650d..2394f896ad 100644 --- a/testsuite/tests/dependent/should_fail/BadTelescope4.stderr +++ b/testsuite/tests/dependent/should_fail/BadTelescope4.stderr @@ -1,12 +1,12 @@ BadTelescope4.hs:9:1: error: - • These kind and type variables: (a :: k1) + • These kind and type variables: (a :: k) (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d) are out of dependency order. Perhaps try this ordering: - k1 - (a :: k1) + k + (a :: k) (b :: Proxy a) (c :: Proxy b) (d :: Proxy a) diff --git a/testsuite/tests/dependent/should_fail/TypeSkolEscape.hs b/testsuite/tests/dependent/should_fail/TypeSkolEscape.hs index 09845ed87e..bbec037487 100644 --- a/testsuite/tests/dependent/should_fail/TypeSkolEscape.hs +++ b/testsuite/tests/dependent/should_fail/TypeSkolEscape.hs @@ -5,4 +5,4 @@ module TypeSkolEscape where import GHC.Types import GHC.Exts -type Bad = forall (v :: Levity) (a :: TYPE v). a +type Bad = forall (v :: RuntimeRep) (a :: TYPE v). a diff --git a/testsuite/tests/dependent/should_fail/TypeSkolEscape.stderr b/testsuite/tests/dependent/should_fail/TypeSkolEscape.stderr index 1574c017ce..a4ce1e4131 100644 --- a/testsuite/tests/dependent/should_fail/TypeSkolEscape.stderr +++ b/testsuite/tests/dependent/should_fail/TypeSkolEscape.stderr @@ -1,7 +1,7 @@ TypeSkolEscape.hs:8:1: error: - Quantified type's kind mentions quantified type variable - (skolem escape) - type: forall (v1 :: Levity) (a1 :: TYPE v1). a1 - of kind: TYPE v - In the type synonym declaration for ‘Bad’ + • Quantified type's kind mentions quantified type variable + (skolem escape) + type: forall (v1 :: RuntimeRep) (a1 :: TYPE v1). a1 + of kind: TYPE v + • In the type synonym declaration for ‘Bad’ diff --git a/testsuite/tests/ghci/scripts/T4175.stdout b/testsuite/tests/ghci/scripts/T4175.stdout index ef5b5c69c1..e1ef925bea 100644 --- a/testsuite/tests/ghci/scripts/T4175.stdout +++ b/testsuite/tests/ghci/scripts/T4175.stdout @@ -1,6 +1,4 @@ -type family A a b - Kind: * -> * -> * - -- Defined at T4175.hs:7:1 +type family A a b :: * -- Defined at T4175.hs:7:1 type instance A (B a) b = () -- Defined at T4175.hs:10:15 type instance A (Maybe a) a = a -- Defined at T4175.hs:9:15 type instance A Int Int = () -- Defined at T4175.hs:8:15 @@ -9,13 +7,11 @@ instance G B -- Defined at T4175.hs:34:10 data instance B () = MkB -- Defined at T4175.hs:13:15 type instance A (B a) b = () -- Defined at T4175.hs:10:15 class C a where - type family D a b - Kind: * -> * -> * + type family D a b :: * -- Defined at T4175.hs:16:5 type instance D () () = Bool -- Defined at T4175.hs:22:10 type instance D Int () = String -- Defined at T4175.hs:19:10 -type family E a - Kind: * -> * +type family E a :: * where E () = Bool E Int = String diff --git a/testsuite/tests/ghci/scripts/T7627.stdout b/testsuite/tests/ghci/scripts/T7627.stdout index 4b16acc1a2..ee6dfa4f10 100644 --- a/testsuite/tests/ghci/scripts/T7627.stdout +++ b/testsuite/tests/ghci/scripts/T7627.stdout @@ -29,11 +29,11 @@ data (#,#) (c :: TYPE a) (d :: TYPE b) = (#,#) c d -- Defined in ‘GHC.Prim’ (,) :: a -> b -> (a, b) (#,#) - :: forall (a :: GHC.Types.Levity) (b :: GHC.Types.Levity) (c :: TYPE - a) (d :: TYPE b). + :: forall (a :: GHC.Types.RuntimeRep) (b :: GHC.Types.RuntimeRep) (c :: TYPE + a) (d :: TYPE b). c -> d -> (# c, d #) ( , ) :: a -> b -> (a, b) (# , #) - :: forall (a :: GHC.Types.Levity) (b :: GHC.Types.Levity) (c :: TYPE - a) (d :: TYPE b). + :: forall (a :: GHC.Types.RuntimeRep) (b :: GHC.Types.RuntimeRep) (c :: TYPE + a) (d :: TYPE b). c -> d -> (# c, d #) diff --git a/testsuite/tests/ghci/scripts/T7939.stdout b/testsuite/tests/ghci/scripts/T7939.stdout index 1e6c5b7548..2b2c8b73ad 100644 --- a/testsuite/tests/ghci/scripts/T7939.stdout +++ b/testsuite/tests/ghci/scripts/T7939.stdout @@ -1,32 +1,25 @@ class Foo (a :: k) where - type family Bar (a :: k) b - Kind: forall k1. k1 -> * -> * + type family Bar (a :: k) b :: * -- Defined at T7939.hs:6:4 Bar :: k -> * -> * -type family F a - Kind: * -> * - -- Defined at T7939.hs:8:1 +type family F a :: * -- Defined at T7939.hs:8:1 type instance F Int = Bool -- Defined at T7939.hs:9:15 F :: * -> * -type family G a - Kind: * -> * +type family G a :: * where G Int = Bool -- Defined at T7939.hs:11:1 G :: * -> * -type family H (a :: Bool) - Kind: Bool -> Bool +type family H (a :: Bool) :: Bool where H 'False = 'True -- Defined at T7939.hs:14:1 H :: Bool -> Bool -type family J (a :: [k]) - Kind: forall k1. [k1] -> Bool +type family J (a :: [k]) :: Bool where [k] J k '[] = 'False [k, (h :: k), (t :: [k])] J k (h : t) = 'True -- Defined at T7939.hs:17:1 J :: [k] -> Bool -type family K (a1 :: [a]) - Kind: forall a2. [a2] -> Maybe a2 +type family K (a1 :: [a]) :: Maybe a where [a] K a '[] = 'Nothing [a, (h :: a), (t :: [a])] K a (h : t) = 'Just h diff --git a/testsuite/tests/ghci/scripts/T8535.stdout b/testsuite/tests/ghci/scripts/T8535.stdout index 2f35e23a77..6eb08cdfe4 100644 --- a/testsuite/tests/ghci/scripts/T8535.stdout +++ b/testsuite/tests/ghci/scripts/T8535.stdout @@ -1,4 +1,4 @@ -data (->) a b -- Defined in ‘GHC.Prim’ +data (->) t1 t2 -- Defined in ‘GHC.Prim’ infixr 0 `(->)` instance Monad ((->) r) -- Defined in ‘GHC.Base’ instance Functor ((->) r) -- Defined in ‘GHC.Base’ diff --git a/testsuite/tests/ghci/scripts/T9181.stdout b/testsuite/tests/ghci/scripts/T9181.stdout index 3482d54ba4..43bbbacd74 100644 --- a/testsuite/tests/ghci/scripts/T9181.stdout +++ b/testsuite/tests/ghci/scripts/T9181.stdout @@ -1,23 +1,23 @@ type family (GHC.TypeLits.*) (a :: GHC.Types.Nat) (b :: GHC.Types.Nat) - Kind: GHC.Types.Nat -> GHC.Types.Nat -> GHC.Types.Nat + :: GHC.Types.Nat type family (GHC.TypeLits.+) (a :: GHC.Types.Nat) (b :: GHC.Types.Nat) - Kind: GHC.Types.Nat -> GHC.Types.Nat -> GHC.Types.Nat + :: GHC.Types.Nat type family (GHC.TypeLits.-) (a :: GHC.Types.Nat) (b :: GHC.Types.Nat) - Kind: GHC.Types.Nat -> GHC.Types.Nat -> GHC.Types.Nat + :: GHC.Types.Nat type (GHC.TypeLits.<=) (x :: GHC.Types.Nat) (y :: GHC.Types.Nat) = - (x GHC.TypeLits.<=? y) ~ 'True + (x GHC.TypeLits.<=? y) ~ 'True :: Constraint type family (GHC.TypeLits.<=?) (a :: GHC.Types.Nat) (b :: GHC.Types.Nat) - Kind: GHC.Types.Nat -> GHC.Types.Nat -> Bool + :: Bool type family GHC.TypeLits.CmpNat (a :: GHC.Types.Nat) (b :: GHC.Types.Nat) - Kind: GHC.Types.Nat -> GHC.Types.Nat -> Ordering + :: Ordering type family GHC.TypeLits.CmpSymbol (a :: GHC.Types.Symbol) (b :: GHC.Types.Symbol) - Kind: GHC.Types.Symbol -> GHC.Types.Symbol -> Ordering + :: Ordering data GHC.TypeLits.ErrorMessage where GHC.TypeLits.Text :: GHC.Types.Symbol -> GHC.TypeLits.ErrorMessage GHC.TypeLits.ShowType :: t -> GHC.TypeLits.ErrorMessage @@ -38,10 +38,10 @@ data GHC.TypeLits.SomeSymbol where GHC.TypeLits.SomeSymbol :: GHC.TypeLits.KnownSymbol n => (Data.Proxy.Proxy n) -> GHC.TypeLits.SomeSymbol type family GHC.TypeLits.TypeError (a :: GHC.TypeLits.ErrorMessage) - Kind: forall b1. GHC.TypeLits.ErrorMessage -> b1 + :: b type family (GHC.TypeLits.^) (a :: GHC.Types.Nat) (b :: GHC.Types.Nat) - Kind: GHC.Types.Nat -> GHC.Types.Nat -> GHC.Types.Nat + :: GHC.Types.Nat GHC.TypeLits.natVal :: GHC.TypeLits.KnownNat n => proxy n -> Integer GHC.TypeLits.natVal' :: diff --git a/testsuite/tests/ghci/scripts/ghci020.stdout b/testsuite/tests/ghci/scripts/ghci020.stdout index 2f35e23a77..6eb08cdfe4 100644 --- a/testsuite/tests/ghci/scripts/ghci020.stdout +++ b/testsuite/tests/ghci/scripts/ghci020.stdout @@ -1,4 +1,4 @@ -data (->) a b -- Defined in ‘GHC.Prim’ +data (->) t1 t2 -- Defined in ‘GHC.Prim’ infixr 0 `(->)` instance Monad ((->) r) -- Defined in ‘GHC.Base’ instance Functor ((->) r) -- Defined in ‘GHC.Base’ diff --git a/testsuite/tests/ghci/should_run/T10145.stdout b/testsuite/tests/ghci/should_run/T10145.stdout index 2f35e23a77..6eb08cdfe4 100644 --- a/testsuite/tests/ghci/should_run/T10145.stdout +++ b/testsuite/tests/ghci/should_run/T10145.stdout @@ -1,4 +1,4 @@ -data (->) a b -- Defined in ‘GHC.Prim’ +data (->) t1 t2 -- Defined in ‘GHC.Prim’ infixr 0 `(->)` instance Monad ((->) r) -- Defined in ‘GHC.Base’ instance Functor ((->) r) -- Defined in ‘GHC.Base’ diff --git a/testsuite/tests/indexed-types/should_compile/T3017.stderr b/testsuite/tests/indexed-types/should_compile/T3017.stderr index 68214e946e..3000395aa2 100644 --- a/testsuite/tests/indexed-types/should_compile/T3017.stderr +++ b/testsuite/tests/indexed-types/should_compile/T3017.stderr @@ -7,13 +7,11 @@ TYPE SIGNATURES forall c t t1. (Elem c ~ (t, t1), Coll c, Num t1, Num t) => c -> c TYPE CONSTRUCTORS class Coll c where - type family Elem c open - Kind: * -> * + type family Elem c :: * open empty :: c insert :: Elem c -> c -> c {-# MINIMAL empty, insert #-} data ListColl a = L [a] - Kind: * -> * COERCION AXIOMS axiom Foo.D:R:ElemListColl :: Elem (ListColl a) = a -- Defined at T3017.hs:13:9 diff --git a/testsuite/tests/indexed-types/should_fail/ClosedFam3.stderr b/testsuite/tests/indexed-types/should_fail/ClosedFam3.stderr index 04eedb1eaf..ba1f46ef47 100644 --- a/testsuite/tests/indexed-types/should_fail/ClosedFam3.stderr +++ b/testsuite/tests/indexed-types/should_fail/ClosedFam3.stderr @@ -1,40 +1,31 @@ -ClosedFam3.hs-boot:5:1: +ClosedFam3.hs-boot:5:1: error: Type constructor ‘Foo’ has conflicting definitions in the module and its hs-boot file - Main module: type family Foo a - Kind: * -> * + Main module: type family Foo a :: * where - Foo Int = Bool - Foo Double = Char - Boot file: type family Foo a - Kind: * -> * - where - Foo Int = Bool + Foo Int = Bool + Foo Double = Char + Boot file: type family Foo a :: * + where Foo Int = Bool -ClosedFam3.hs-boot:8:1: +ClosedFam3.hs-boot:8:1: error: Type constructor ‘Bar’ has conflicting definitions in the module and its hs-boot file - Main module: type family Bar a - Kind: * -> * + Main module: type family Bar a :: * where - Bar Int = Bool - Bar Double = Double - Boot file: type family Bar a - Kind: * -> * + Bar Int = Bool + Bar Double = Double + Boot file: type family Bar a :: * where - Bar Int = Bool - Bar Double = Char + Bar Int = Bool + Bar Double = Char -ClosedFam3.hs-boot:12:1: +ClosedFam3.hs-boot:12:1: error: Type constructor ‘Baz’ has conflicting definitions in the module and its hs-boot file - Main module: type family Baz a - Kind: * -> * - where - Baz Int = Bool - Boot file: type family Baz (a :: k) - Kind: forall k1. k1 -> * - where - Baz * Int = Bool + Main module: type family Baz a :: * + where Baz Int = Bool + Boot file: type family Baz (a :: k) :: * + where Baz * Int = Bool The types have different kinds diff --git a/testsuite/tests/indexed-types/should_fail/Overlap4.stderr b/testsuite/tests/indexed-types/should_fail/Overlap4.stderr index d64036c4bc..937a18d861 100644 --- a/testsuite/tests/indexed-types/should_fail/Overlap4.stderr +++ b/testsuite/tests/indexed-types/should_fail/Overlap4.stderr @@ -1,5 +1,6 @@ -Overlap4.hs:7:3: - Number of parameters must match family declaration; expected 2 - In the equations for closed type family ‘F’ - In the type family declaration for ‘F’ +Overlap4.hs:7:12: error: + • Expecting one more argument to ‘Maybe’ + Expected a type, but ‘Maybe’ has kind ‘* -> *’ + • In the type ‘Maybe’ + In the type family declaration for ‘F’ diff --git a/testsuite/tests/indexed-types/should_fail/SimpleFail1a.stderr b/testsuite/tests/indexed-types/should_fail/SimpleFail1a.stderr index 8637eaa892..b0c91af91a 100644 --- a/testsuite/tests/indexed-types/should_fail/SimpleFail1a.stderr +++ b/testsuite/tests/indexed-types/should_fail/SimpleFail1a.stderr @@ -1,5 +1,4 @@ SimpleFail1a.hs:4:1: error: - • Expecting one more argument to ‘T1 Int’ - Expected a type, but ‘T1 Int’ has kind ‘* -> *’ + • Number of parameters must match family declaration; expected 2 • In the data instance declaration for ‘T1’ diff --git a/testsuite/tests/indexed-types/should_fail/TyFamArity1.stderr b/testsuite/tests/indexed-types/should_fail/TyFamArity1.stderr index b99c8d9934..8b3d5f5910 100644 --- a/testsuite/tests/indexed-types/should_fail/TyFamArity1.stderr +++ b/testsuite/tests/indexed-types/should_fail/TyFamArity1.stderr @@ -1,4 +1,6 @@ -TyFamArity1.hs:4:15: - Number of parameters must match family declaration; expected 2 - In the type instance declaration for ‘T’ +TyFamArity1.hs:4:23: error: + • Expecting one more argument to ‘IO’ + Expected a type, but ‘IO’ has kind ‘* -> *’ + • In the type ‘IO’ + In the type instance declaration for ‘T’ diff --git a/testsuite/tests/indexed-types/should_fail/TyFamArity2.stderr b/testsuite/tests/indexed-types/should_fail/TyFamArity2.stderr index 28107aaed6..778d8ab9f4 100644 --- a/testsuite/tests/indexed-types/should_fail/TyFamArity2.stderr +++ b/testsuite/tests/indexed-types/should_fail/TyFamArity2.stderr @@ -1,4 +1,11 @@ -TyFamArity2.hs:4:15: - Number of parameters must match family declaration; expected 1 - In the type instance declaration for ‘T’ +TyFamArity2.hs:4:15: error: + • Too many parameters to T: + Float is unexpected; + expected only one parameter + • In the type instance declaration for ‘T’ + +TyFamArity2.hs:4:29: error: + • Expected kind ‘* -> *’, but ‘Char’ has kind ‘*’ + • In the type ‘Char’ + In the type instance declaration for ‘T’ diff --git a/testsuite/tests/indexed-types/should_run/T11465a.hs b/testsuite/tests/indexed-types/should_run/T11465a.hs index 41fc19738c..d3626cf198 100644 --- a/testsuite/tests/indexed-types/should_run/T11465a.hs +++ b/testsuite/tests/indexed-types/should_run/T11465a.hs @@ -7,7 +7,7 @@ import GHC.Exts import GHC.Types -class BoxIt (a :: TYPE 'Unlifted) where +class BoxIt (a :: TYPE 'WordRep) where type Boxed a :: * boxed :: a -> Boxed a diff --git a/testsuite/tests/partial-sigs/should_compile/ADT.stderr b/testsuite/tests/partial-sigs/should_compile/ADT.stderr index 0da9e2284a..10658a2d4a 100644 --- a/testsuite/tests/partial-sigs/should_compile/ADT.stderr +++ b/testsuite/tests/partial-sigs/should_compile/ADT.stderr @@ -3,7 +3,6 @@ TYPE SIGNATURES bar :: Int -> Foo Bool () Int TYPE CONSTRUCTORS data Foo x y z = Foo x y z - Kind: * -> * -> * -> * COERCION AXIOMS Dependent modules: [] Dependent packages: [base-4.9.0.0, ghc-prim-0.5.0.0, diff --git a/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr b/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr index 6a2ac84f6c..7b12afc302 100644 --- a/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr +++ b/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr @@ -12,7 +12,6 @@ TYPE SIGNATURES foo :: Sing 'A TYPE CONSTRUCTORS data MyKind = A | B - Kind: * data family Sing (a :: k) COERCION AXIOMS axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 :: diff --git a/testsuite/tests/partial-sigs/should_compile/Meltdown.stderr b/testsuite/tests/partial-sigs/should_compile/Meltdown.stderr index cf6a223c45..29619d15ed 100644 --- a/testsuite/tests/partial-sigs/should_compile/Meltdown.stderr +++ b/testsuite/tests/partial-sigs/should_compile/Meltdown.stderr @@ -6,7 +6,6 @@ TYPE SIGNATURES TYPE CONSTRUCTORS type role NukeMonad phantom phantom phantom data NukeMonad a b c - Kind: * -> * -> * -> * COERCION AXIOMS INSTANCES instance Functor (NukeMonad a b) -- Defined at Meltdown.hs:8:10 @@ -15,4 +14,4 @@ INSTANCES instance Monad (NukeMonad a b) -- Defined at Meltdown.hs:15:10 Dependent modules: [] Dependent packages: [base-4.9.0.0, ghc-prim-0.5.0.0, - integer-gmp-1.0.0.0] + integer-gmp-1.0.0.1] diff --git a/testsuite/tests/partial-sigs/should_compile/NamedWildcardInDataFamilyInstanceLHS.stderr b/testsuite/tests/partial-sigs/should_compile/NamedWildcardInDataFamilyInstanceLHS.stderr index b335118ed8..5b8982ba16 100644 --- a/testsuite/tests/partial-sigs/should_compile/NamedWildcardInDataFamilyInstanceLHS.stderr +++ b/testsuite/tests/partial-sigs/should_compile/NamedWildcardInDataFamilyInstanceLHS.stderr @@ -11,7 +11,6 @@ TYPE SIGNATURES NamedWildcardInDataFamilyInstanceLHS.R:SingMyKind_a _a TYPE CONSTRUCTORS data MyKind = A | B - Kind: * data family Sing (a :: k) COERCION AXIOMS axiom NamedWildcardInDataFamilyInstanceLHS.D:R:SingMyKind_a0 :: diff --git a/testsuite/tests/partial-sigs/should_compile/NamedWildcardInTypeFamilyInstanceLHS.stderr b/testsuite/tests/partial-sigs/should_compile/NamedWildcardInTypeFamilyInstanceLHS.stderr index c39ff6f254..bba0917ec3 100644 --- a/testsuite/tests/partial-sigs/should_compile/NamedWildcardInTypeFamilyInstanceLHS.stderr +++ b/testsuite/tests/partial-sigs/should_compile/NamedWildcardInTypeFamilyInstanceLHS.stderr @@ -1,7 +1,6 @@ TYPE SIGNATURES TYPE CONSTRUCTORS - type family F a - Kind: * -> * + type family F a :: * where [_t] F _t = Int axiom NamedWildcardInTypeFamilyInstanceLHS.D:R:F diff --git a/testsuite/tests/partial-sigs/should_compile/SkipMany.stderr b/testsuite/tests/partial-sigs/should_compile/SkipMany.stderr index be635e620d..5b94077eb0 100644 --- a/testsuite/tests/partial-sigs/should_compile/SkipMany.stderr +++ b/testsuite/tests/partial-sigs/should_compile/SkipMany.stderr @@ -7,7 +7,6 @@ TYPE SIGNATURES forall tok st a. GenParser tok st a -> GenParser tok st () TYPE CONSTRUCTORS data GenParser tok st a = GenParser tok st a - Kind: * -> * -> * -> * COERCION AXIOMS Dependent modules: [] Dependent packages: [base-4.9.0.0, ghc-prim-0.5.0.0, diff --git a/testsuite/tests/partial-sigs/should_compile/TypeFamilyInstanceLHS.stderr b/testsuite/tests/partial-sigs/should_compile/TypeFamilyInstanceLHS.stderr index 0800286480..78377fb81d 100644 --- a/testsuite/tests/partial-sigs/should_compile/TypeFamilyInstanceLHS.stderr +++ b/testsuite/tests/partial-sigs/should_compile/TypeFamilyInstanceLHS.stderr @@ -1,8 +1,7 @@ TYPE SIGNATURES foo :: F Int Char -> Int TYPE CONSTRUCTORS - type family F a b open - Kind: * -> * -> * + type family F a b :: * open COERCION AXIOMS axiom TypeFamilyInstanceLHS.D:R:FBool_ :: F Bool _ = Bool -- Defined at TypeFamilyInstanceLHS.hs:6:15 diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index 776e062e7e..61ac9b2076 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -747,8 +747,9 @@ test('T9233', test('T10370', [ only_ways(['optasm']), compiler_stats_num_field('max_bytes_used', # Note [residency] - [(wordsize(64), 19548720, 15), + [(wordsize(64), 22823976, 15), # 2015-10-22 19548720 + # 2016-02-24 22823976 Changing Levity to RuntimeRep; not sure why this regresses though, even after some analysis (wordsize(32), 11371496, 15), # 2015-10-22 11371496 ]), diff --git a/testsuite/tests/polykinds/T11399.stderr b/testsuite/tests/polykinds/T11399.stderr index 31ccdf80b5..5e09870088 100644 --- a/testsuite/tests/polykinds/T11399.stderr +++ b/testsuite/tests/polykinds/T11399.stderr @@ -1,9 +1,9 @@ T11399.hs:7:32: error: - • Couldn't match kind ‘*’ with ‘GHC.Types.Levity’ + • Couldn't match kind ‘*’ with ‘GHC.Types.RuntimeRep’ When matching kinds k :: * -> * - TYPE :: GHC.Types.Levity -> * + TYPE :: GHC.Types.RuntimeRep -> * Expected kind ‘* -> *’, but ‘UhOh k’ has kind ‘k * -> *’ • In the first argument of ‘Functor’, namely ‘UhOh k’ In the instance declaration for ‘Functor (UhOh k)’ diff --git a/testsuite/tests/polykinds/T7328.stderr b/testsuite/tests/polykinds/T7328.stderr index 31b425f644..58e883e142 100644 --- a/testsuite/tests/polykinds/T7328.stderr +++ b/testsuite/tests/polykinds/T7328.stderr @@ -1,6 +1,6 @@ T7328.hs:8:34: error: - • Occurs check: cannot construct the infinite kind: k10 ~ k0 -> k10 + • Occurs check: cannot construct the infinite kind: k0 ~ k1 -> k0 • In the first argument of ‘Foo’, namely ‘f’ In the first argument of ‘Proxy’, namely ‘Foo f’ In the type signature: diff --git a/testsuite/tests/polykinds/TidyClassKinds.stderr b/testsuite/tests/polykinds/TidyClassKinds.stderr index 69ca49c188..5cbea8b417 100644 --- a/testsuite/tests/polykinds/TidyClassKinds.stderr +++ b/testsuite/tests/polykinds/TidyClassKinds.stderr @@ -1,7 +1,7 @@ TidyClassKinds.hs:12:10: error: • Illegal instance declaration for - ‘Poly (k1 -> *) (k1 -> *) (ProxySyn k1) (ProxySyn k1)’ + ‘Poly (k -> *) (k -> *) (ProxySyn k) (ProxySyn k)’ (All instance types must be of the form (T t1 ... tn) where T is not a synonym. Use TypeSynonymInstances if you want to disable this.) diff --git a/testsuite/tests/roles/should_compile/Roles1.stderr b/testsuite/tests/roles/should_compile/Roles1.stderr index 6ea24f009b..fe0658b56c 100644 --- a/testsuite/tests/roles/should_compile/Roles1.stderr +++ b/testsuite/tests/roles/should_compile/Roles1.stderr @@ -9,23 +9,16 @@ TYPE SIGNATURES TYPE CONSTRUCTORS type role T1 nominal data T1 a = K1 a - Kind: * -> * data T2 a = K2 a - Kind: * -> * type role T3 phantom data T3 (a :: k) = K3 - Kind: forall k1. k1 -> * type role T4 nominal nominal data T4 (a :: * -> *) b = K4 (a b) - Kind: (* -> *) -> * -> * data T5 a = K5 a - Kind: * -> * type role T6 phantom data T6 (a :: k) = K6 - Kind: forall {k1}. k1 -> * type role T7 phantom representational data T7 (a :: k) b = K7 b - Kind: forall {k1}. k1 -> * -> * COERCION AXIOMS Dependent modules: [] Dependent packages: [base-4.9.0.0, ghc-prim-0.5.0.0, diff --git a/testsuite/tests/roles/should_compile/Roles2.stderr b/testsuite/tests/roles/should_compile/Roles2.stderr index 7c075b9bce..65ba748863 100644 --- a/testsuite/tests/roles/should_compile/Roles2.stderr +++ b/testsuite/tests/roles/should_compile/Roles2.stderr @@ -3,10 +3,8 @@ TYPE SIGNATURES Roles2.K2 :: forall a. FunPtr a -> T2 a TYPE CONSTRUCTORS data T1 a = K1 (IO a) - Kind: * -> * type role T2 phantom data T2 a = K2 (FunPtr a) - Kind: * -> * COERCION AXIOMS Dependent modules: [] Dependent packages: [base-4.9.0.0, ghc-prim-0.5.0.0, diff --git a/testsuite/tests/roles/should_compile/Roles3.stderr b/testsuite/tests/roles/should_compile/Roles3.stderr index 544e497c2d..ca496ed042 100644 --- a/testsuite/tests/roles/should_compile/Roles3.stderr +++ b/testsuite/tests/roles/should_compile/Roles3.stderr @@ -11,15 +11,13 @@ TYPE CONSTRUCTORS meth2 :: a ~ b => a -> b {-# MINIMAL meth2 #-} class C3 a b where - type family F3 b open - Kind: * -> * + type family F3 b :: * open meth3 :: a -> F3 b -> F3 b {-# MINIMAL meth3 #-} class C4 a b where meth4 :: a -> F4 b -> F4 b {-# MINIMAL meth4 #-} - type family F4 a open - Kind: * -> * + type family F4 a :: * open type Syn1 a = F4 a type Syn2 a = [a] COERCION AXIOMS diff --git a/testsuite/tests/roles/should_compile/T8958.stderr b/testsuite/tests/roles/should_compile/T8958.stderr index 91b58a1ba6..9b4e2d911c 100644 --- a/testsuite/tests/roles/should_compile/T8958.stderr +++ b/testsuite/tests/roles/should_compile/T8958.stderr @@ -6,7 +6,6 @@ TYPE SIGNATURES TYPE CONSTRUCTORS type role Map nominal representational newtype (Nominal k, Representational v) => Map k v = MkMap [(k, v)] - Kind: * -> * -> * class Nominal a type role Representational representational class Representational a diff --git a/testsuite/tests/simplCore/should_compile/T9400.stderr b/testsuite/tests/simplCore/should_compile/T9400.stderr index 996890ff94..3f6ae06a20 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 - @ 'Lifted @ (IO ()) "T9400.hs:(17,5)-(18,29)|case"#)))) + @ 'PtrRepLifted @ (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 41824247d7..061a81fee0 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=DmdType x] Roman.foo3 = Control.Exception.Base.patError - @ 'GHC.Types.Lifted + @ 'GHC.Types.PtrRepLifted @ Int "spec-inline.hs:(19,5)-(29,25)|function go"# diff --git a/testsuite/tests/th/TH_Roles2.stderr b/testsuite/tests/th/TH_Roles2.stderr index 174affe833..afcac7c6b7 100644 --- a/testsuite/tests/th/TH_Roles2.stderr +++ b/testsuite/tests/th/TH_Roles2.stderr @@ -2,12 +2,11 @@ TYPE SIGNATURES TYPE CONSTRUCTORS type role T representational data T (a :: k) - Kind: forall k1. k1 -> * COERCION AXIOMS Dependent modules: [] -Dependent packages: [array-0.5.1.0, base-4.9.0.0, binary-0.8.0.0, +Dependent packages: [array-0.5.1.0, base-4.9.0.0, binary-0.8.2.0, bytestring-0.10.7.0, containers-0.5.7.1, deepseq-1.4.2.0, - ghc-boot-0.0.0.0, ghc-prim-0.5.0.0, integer-gmp-1.0.0.0, + ghc-boot-8.1, ghc-prim-0.5.0.0, integer-gmp-1.0.0.1, pretty-1.1.3.2, template-haskell-2.11.0.0] ==================== Typechecker ==================== diff --git a/testsuite/tests/typecheck/should_compile/tc231.stderr b/testsuite/tests/typecheck/should_compile/tc231.stderr index 8c35af42cb..dd5624849a 100644 --- a/testsuite/tests/typecheck/should_compile/tc231.stderr +++ b/testsuite/tests/typecheck/should_compile/tc231.stderr @@ -10,9 +10,7 @@ TYPE SIGNATURES s :: forall t t1. Q t (Z [Char]) t1 -> Q t (Z [Char]) t1 TYPE CONSTRUCTORS data Q s a chain = Node s a chain - Kind: * -> * -> * -> * data Z a = Z a - Kind: * -> * class Zork s a b | a -> b where huh :: Q s a chain -> ST s () {-# MINIMAL huh #-} diff --git a/testsuite/tests/typecheck/should_run/KindInvariant.stderr b/testsuite/tests/typecheck/should_run/KindInvariant.stderr index 777b802415..3fe8131daf 100644 --- a/testsuite/tests/typecheck/should_run/KindInvariant.stderr +++ b/testsuite/tests/typecheck/should_run/KindInvariant.stderr @@ -1,5 +1,6 @@ :1:3: error: - • Expected kind ‘* -> *’, but ‘State#’ has kind ‘* -> #’ + • Expected kind ‘* -> *’, + but ‘State#’ has kind ‘* -> TYPE 'VoidRep’ • In the first argument of ‘T’, namely ‘State#’ In the type ‘T State#’ diff --git a/testsuite/tests/typecheck/should_run/TypeOf.hs b/testsuite/tests/typecheck/should_run/TypeOf.hs index 12184e7a1c..efd26f9640 100644 --- a/testsuite/tests/typecheck/should_run/TypeOf.hs +++ b/testsuite/tests/typecheck/should_run/TypeOf.hs @@ -27,8 +27,8 @@ main = do print $ typeOf (Proxy :: Proxy [1,2,3]) print $ typeOf (Proxy :: Proxy 'EQ) print $ typeOf (Proxy :: Proxy TYPE) - print $ typeOf (Proxy :: Proxy (TYPE 'Lifted)) + print $ typeOf (Proxy :: Proxy (TYPE 'PtrRepLifted)) print $ typeOf (Proxy :: Proxy *) print $ typeOf (Proxy :: Proxy ★) - print $ typeOf (Proxy :: Proxy 'Lifted) + print $ typeOf (Proxy :: Proxy 'PtrRepLifted) print $ typeOf (Proxy :: Proxy (~~)) diff --git a/testsuite/tests/typecheck/should_run/TypeOf.stdout b/testsuite/tests/typecheck/should_run/TypeOf.stdout index ffc2133e20..6f160f544c 100644 --- a/testsuite/tests/typecheck/should_run/TypeOf.stdout +++ b/testsuite/tests/typecheck/should_run/TypeOf.stdout @@ -15,9 +15,9 @@ Proxy Symbol "hello world" Proxy Nat 1 Proxy [Nat] (': Nat 1 (': Nat 2 (': Nat 3 '[]))) Proxy Ordering 'EQ -Proxy (Levity -> Constraint) TYPE +Proxy (RuntimeRep -> Constraint) TYPE Proxy Constraint Constraint Proxy Constraint Constraint Proxy Constraint Constraint -Proxy Levity 'Lifted +Proxy RuntimeRep 'PtrRepLifted Proxy (Constraint -> Constraint -> Constraint) ~~ diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs index e6af0f200e..294591444d 100644 --- a/utils/genprimopcode/Main.hs +++ b/utils/genprimopcode/Main.hs @@ -66,7 +66,7 @@ desugarVectorSpec i = case vecOptions i of | drop len s == suf = Just (take len s) | otherwise = Nothing where - len = length s - length suf + len = length s - length suf lowerHead s = toLower (head s) : tail s @@ -121,37 +121,37 @@ main = getArgs >>= \args -> -> seq (sanityTop p_o_specs) ( case head args of - "--data-decl" + "--data-decl" -> putStr (gen_data_decl p_o_specs) - "--has-side-effects" - -> putStr (gen_switch_from_attribs - "has_side_effects" + "--has-side-effects" + -> putStr (gen_switch_from_attribs + "has_side_effects" "primOpHasSideEffects" p_o_specs) - "--out-of-line" - -> putStr (gen_switch_from_attribs - "out_of_line" + "--out-of-line" + -> putStr (gen_switch_from_attribs + "out_of_line" "primOpOutOfLine" p_o_specs) - "--commutable" - -> putStr (gen_switch_from_attribs - "commutable" + "--commutable" + -> putStr (gen_switch_from_attribs + "commutable" "commutableOp" p_o_specs) "--code-size" - -> putStr (gen_switch_from_attribs + -> putStr (gen_switch_from_attribs "code_size" "primOpCodeSize" p_o_specs) "--can-fail" -> putStr (gen_switch_from_attribs - "can_fail" + "can_fail" "primOpCanFail" p_o_specs) - "--strictness" - -> putStr (gen_switch_from_attribs - "strictness" + "--strictness" + -> putStr (gen_switch_from_attribs + "strictness" "primOpStrictness" p_o_specs) "--fixity" @@ -159,31 +159,31 @@ main = getArgs >>= \args -> "fixity" "primOpFixity" p_o_specs) - "--primop-primop-info" + "--primop-primop-info" -> putStr (gen_primop_info p_o_specs) - "--primop-tag" + "--primop-tag" -> putStr (gen_primop_tag p_o_specs) - "--primop-list" + "--primop-list" -> putStr (gen_primop_list p_o_specs) - "--primop-vector-uniques" + "--primop-vector-uniques" -> putStr (gen_primop_vector_uniques p_o_specs) - "--primop-vector-tys" + "--primop-vector-tys" -> putStr (gen_primop_vector_tys p_o_specs) - "--primop-vector-tys-exports" + "--primop-vector-tys-exports" -> putStr (gen_primop_vector_tys_exports p_o_specs) - "--primop-vector-tycons" + "--primop-vector-tycons" -> putStr (gen_primop_vector_tycons p_o_specs) - "--make-haskell-wrappers" + "--make-haskell-wrappers" -> putStr (gen_wrappers p_o_specs) - - "--make-haskell-source" + + "--make-haskell-source" -> putStr (gen_hs_source p_o_specs) "--make-latex-doc" @@ -193,7 +193,7 @@ main = getArgs >>= \args -> ) known_args :: [String] -known_args +known_args = [ "--data-decl", "--has-side-effects", "--out-of-line", @@ -391,12 +391,12 @@ pprTy = pty gen_latex_doc :: Info -> String gen_latex_doc (Info defaults entries) - = "\\primopdefaults{" + = "\\primopdefaults{" ++ mk_options defaults ++ "}\n" ++ (concat (map mk_entry entries)) where mk_entry (PrimOpSpec {cons=constr,name=n,ty=t,cat=c,desc=d,opts=o}) = - "\\primopdesc{" + "\\primopdesc{" ++ latex_encode constr ++ "}{" ++ latex_encode n ++ "}{" ++ latex_encode (zencode n) ++ "}{" @@ -409,7 +409,7 @@ gen_latex_doc (Info defaults entries) mk_entry (PrimVecOpSpec {}) = "" mk_entry (Section {title=ti,desc=d}) = - "\\primopsection{" + "\\primopsection{" ++ latex_encode ti ++ "}{" ++ d ++ "}\n" mk_entry (PrimTypeSpec {ty=t,desc=d,opts=o}) = @@ -438,7 +438,7 @@ gen_latex_doc (Info defaults entries) pbty t = paty t paty (TyVar tv) = tv paty t = "(" ++ pty t ++ ")" - + mk_core_ty typ = foralls ++ (pty typ) where pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2 pty (TyC t1 t2) = pbty t1 ++ " => " ++ pty t2 @@ -453,7 +453,7 @@ gen_latex_doc (Info defaults entries) utuplenm n = "(#" ++ (replicate (n-1) ',') ++ "#)" foralls = if tvars == [] then "" else "%forall " ++ (tbinds tvars) tvars = tvars_of typ - tbinds [] = ". " + tbinds [] = ". " tbinds ("o":tbs) = "(o::?) " ++ (tbinds tbs) tbinds (tv:tbs) = tv ++ " " ++ (tbinds tbs) tvars_of (TyF t1 t2) = tvars_of t1 `union` tvars_of t2 @@ -461,7 +461,7 @@ gen_latex_doc (Info defaults entries) tvars_of (TyApp _ ts) = foldl union [] (map tvars_of ts) tvars_of (TyUTup ts) = foldr union [] (map tvars_of ts) tvars_of (TyVar tv) = [tv] - + mk_options o = "\\primoptions{" ++ mk_has_side_effects o ++ "}{" @@ -488,12 +488,12 @@ gen_latex_doc (Info defaults entries) Just (OptionFixity _) -> error "Fixity value for boolean option" Just (OptionVector _) -> error "vector template for boolean option" Nothing -> "" - - mk_strictness o = + + mk_strictness o = case lookup_attrib "strictness" o of Just (OptionString _ s) -> s -- for now Just _ -> error "Wrong value for strictness" - Nothing -> "" + Nothing -> "" mk_fixity o = case lookup_attrib "fixity" o of Just (OptionFixity (Just (Fixity _ i d))) @@ -514,19 +514,19 @@ gen_latex_doc (Info defaults entries) (n, ')' : _) -> Just ('Z' : shows (n+1) "T") _ -> Nothing maybe_tuple _ = Nothing - + count_commas :: Int -> String -> (Int, String) count_commas n (',' : cs) = count_commas (n+1) cs count_commas n cs = (n,cs) - + unencodedChar :: Char -> Bool -- True for chars that don't need encoding unencodedChar 'Z' = False unencodedChar 'z' = False unencodedChar c = isAlphaNum c - + encode_ch :: Char -> String encode_ch c | unencodedChar c = [c] -- Common case first - + -- Constructors encode_ch '(' = "ZL" -- Needed for things like (,), and (->) encode_ch ')' = "ZR" -- For symmetry with ( @@ -534,7 +534,7 @@ gen_latex_doc (Info defaults entries) encode_ch ']' = "ZN" encode_ch ':' = "ZC" encode_ch 'Z' = "ZZ" - + -- Variables encode_ch 'z' = "zz" encode_ch '&' = "za" @@ -556,7 +556,7 @@ gen_latex_doc (Info defaults entries) encode_ch '_' = "zu" encode_ch '%' = "zv" encode_ch c = 'z' : shows (ord c) "U" - + latex_encode [] = [] latex_encode (c:cs) | c `elem` "#$%&_^{}" = "\\" ++ c:(latex_encode cs) latex_encode ('~':cs) = "\\verb!~!" ++ (latex_encode cs) @@ -568,8 +568,8 @@ gen_wrappers (Info _ entries) = "{-# LANGUAGE MagicHash, NoImplicitPrelude, UnboxedTuples #-}\n" -- Dependencies on Prelude must be explicit in libraries/base, but we -- don't need the Prelude here so we add NoImplicitPrelude. - ++ "module GHC.PrimopWrappers where\n" - ++ "import qualified GHC.Prim\n" + ++ "module GHC.PrimopWrappers where\n" + ++ "import qualified GHC.Prim\n" ++ "import GHC.Tuple ()\n" ++ "import GHC.Prim (" ++ types ++ ")\n" ++ unlines (concatMap f specs) @@ -591,7 +591,7 @@ gen_wrappers (Info _ entries) | otherwise = "(" ++ nm ++ ")" dodgy spec - = name spec `elem` + = name spec `elem` [-- tagToEnum# is really magical, and can't have -- a wrapper since its implementation depends on -- the type of its result @@ -610,7 +610,7 @@ gen_primop_list (Info _ entries) [ " [" ++ cons first ] ++ map (\p -> " , " ++ cons p) rest - ++ + ++ [ " ]" ] ) where (first:rest) = concatMap desugarVectorSpec (filter is_primop entries) @@ -699,7 +699,7 @@ gen_data_decl (Info _ entries) = ++ unlines (map (" | "++) (tail conss)) where conss = map genCons (filter is_primop entries) - + genCons :: Entry -> String genCons entry = case vecOptions entry of @@ -728,7 +728,7 @@ gen_switch_from_attribs attrib_name fn_name (Info defaults entries) in case defv of Nothing -> error ("gen_switch_from: " ++ attrib_name) - Just xx + Just xx -> unlines alternatives ++ fn_name ++ " _ = " ++ getAltRhs xx ++ "\n" @@ -750,9 +750,9 @@ mkPOI_LHS_text i mkPOI_RHS_text :: Entry -> String mkPOI_RHS_text i = case cat i of - Compare + Compare -> case ty i of - TyF t1 (TyF _ _) + TyF t1 (TyF _ _) -> "mkCompare " ++ sl_name i ++ ppType t1 _ -> error "Type error in comparison op" Monadic @@ -769,7 +769,7 @@ mkPOI_RHS_text i -> let (argTys, resTy) = flatTys (ty i) tvs = nub (tvsIn (ty i)) in - "mkGenPrimOp " ++ sl_name i ++ " " + "mkGenPrimOp " ++ sl_name i ++ " " ++ listify (map ppTyVar tvs) ++ " " ++ listify (map ppType argTys) ++ " " ++ "(" ++ ppType resTy ++ ")" @@ -782,7 +782,7 @@ ppTyVar "a" = "alphaTyVar" ppTyVar "b" = "betaTyVar" ppTyVar "c" = "gammaTyVar" ppTyVar "s" = "deltaTyVar" -ppTyVar "o" = "levity1TyVar, openAlphaTyVar" +ppTyVar "o" = "runtimeRep1TyVar, openAlphaTyVar" ppTyVar _ = error "Unknown type var" ppType :: Ty -> String @@ -813,14 +813,14 @@ ppType (TyVar "s") = "deltaTy" ppType (TyVar "o") = "openAlphaTy" ppType (TyApp (TyCon "State#") [x]) = "mkStatePrimTy " ++ ppType x -ppType (TyApp (TyCon "MutVar#") [x,y]) = "mkMutVarPrimTy " ++ ppType x +ppType (TyApp (TyCon "MutVar#") [x,y]) = "mkMutVarPrimTy " ++ ppType x ++ " " ++ ppType y ppType (TyApp (TyCon "MutableArray#") [x,y]) = "mkMutableArrayPrimTy " ++ ppType x ++ " " ++ ppType y ppType (TyApp (TyCon "MutableArrayArray#") [x]) = "mkMutableArrayArrayPrimTy " ++ ppType x ppType (TyApp (TyCon "SmallMutableArray#") [x,y]) = "mkSmallMutableArrayPrimTy " ++ ppType x ++ " " ++ ppType y -ppType (TyApp (TyCon "MutableByteArray#") [x]) = "mkMutableByteArrayPrimTy " +ppType (TyApp (TyCon "MutableByteArray#") [x]) = "mkMutableByteArrayPrimTy " ++ ppType x ppType (TyApp (TyCon "Array#") [x]) = "mkArrayPrimTy " ++ ppType x ppType (TyApp (TyCon "ArrayArray#") []) = "mkArrayArrayPrimTy" @@ -831,14 +831,14 @@ ppType (TyApp (TyCon "Weak#") [x]) = "mkWeakPrimTy " ++ ppType x ppType (TyApp (TyCon "StablePtr#") [x]) = "mkStablePtrPrimTy " ++ ppType x ppType (TyApp (TyCon "StableName#") [x]) = "mkStableNamePrimTy " ++ ppType x -ppType (TyApp (TyCon "MVar#") [x,y]) = "mkMVarPrimTy " ++ ppType x +ppType (TyApp (TyCon "MVar#") [x,y]) = "mkMVarPrimTy " ++ ppType x ++ " " ++ ppType y -ppType (TyApp (TyCon "TVar#") [x,y]) = "mkTVarPrimTy " ++ ppType x +ppType (TyApp (TyCon "TVar#") [x,y]) = "mkTVarPrimTy " ++ ppType x ++ " " ++ ppType y ppType (TyApp (VecTyCon _ pptc) []) = pptc -ppType (TyUTup ts) = "(mkTupleTy Unboxed " +ppType (TyUTup ts) = "(mkTupleTy Unboxed " ++ listify (map ppType ts) ++ ")" ppType (TyF s d) = "(mkFunTy (" ++ ppType s ++ ") (" ++ ppType d ++ "))" diff --git a/utils/haddock b/utils/haddock index 23f1420c64..ab954263a7 160000 --- a/utils/haddock +++ b/utils/haddock @@ -1 +1 @@ -Subproject commit 23f1420c64899fff2fe45a8b797e0d7e8c931c7d +Subproject commit ab954263a793d8ced734459d6194a5d89214b66c -- cgit v1.2.1