X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=47b8c31f3c2900977f27614a7530793a7746cdb4;hp=b03870eae920ba92c1b0af40cb33650c56a73d66;hb=215ce9f15215399ce30ae55c9521087847d78646;hpb=58521c72cec262496dabf5fffb057d25ab17a0f7 diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index b03870e..47b8c31 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -37,7 +37,6 @@ import VarSet import Name import Outputable import Maybes -import Monad import Unify import Util import SrcLoc @@ -49,6 +48,7 @@ import Unique ( mkBuiltinUnique ) import BasicTypes import Bag +import Control.Monad import Data.List \end{code} @@ -249,8 +249,8 @@ tcFamInstDecl (L loc decl) = -- Prime error recovery, set source location setSrcSpan loc $ tcAddDeclCtxt decl $ - do { -- type families require -XTypeFamilies and can't be in an - -- hs-boot file + do { -- type family instances require -XTypeFamilies + -- and can't (currently) be in an hs-boot file ; type_families <- doptM Opt_TypeFamilies ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? ; checkTc type_families $ badFamInstDecl (tcdLName decl) @@ -481,7 +481,7 @@ getInitialKind decl ; res_kind <- mk_res_kind decl ; return (tcdName decl, mkArrowKinds arg_kinds res_kind) } where - mk_arg_kind (UserTyVar _) = newKindVar + mk_arg_kind (UserTyVar _ _) = newKindVar mk_arg_kind (KindedTyVar _ kind) = return kind mk_res_kind (TyFamily { tcdKind = Just kind }) = return kind @@ -513,7 +513,7 @@ kcSynDecl (AcyclicSCC (L loc decl)) <+> brackets (ppr k_tvs)) ; (k_rhs, rhs_kind) <- kcLHsType (tcdSynRhs decl) ; traceTc (text "kcd2" <+> ppr (unLoc (tcdLName decl))) - ; let tc_kind = foldr (mkArrowKind . kindedTyVarKind) rhs_kind k_tvs + ; let tc_kind = foldr (mkArrowKind . hsTyVarKind . unLoc) rhs_kind k_tvs ; return (L loc (decl { tcdTyVars = k_tvs, tcdSynRhs = k_rhs }), (unLoc (tcdLName decl), tc_kind)) }) @@ -521,10 +521,6 @@ kcSynDecl (CyclicSCC decls) = do { recSynErr decls; failM } -- Fail here to avoid error cascade -- of out-of-scope tycons -kindedTyVarKind :: LHsTyVarBndr Name -> Kind -kindedTyVarKind (L _ (KindedTyVar _ k)) = k -kindedTyVarKind x = pprPanic "kindedTyVarKind" (ppr x) - ------------------------------------------------------------------------ kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name) -- Not used for type synonyms (see kcSynDecl) @@ -566,14 +562,16 @@ kcTyClDeclBody decl thing_inside = tcAddDeclCtxt decl $ do { tc_ty_thing <- tcLookupLocated (tcdLName decl) ; let tc_kind = case tc_ty_thing of - AThing k -> k - _ -> pprPanic "kcTyClDeclBody" (ppr tc_ty_thing) + AThing k -> k + _ -> pprPanic "kcTyClDeclBody" (ppr tc_ty_thing) (kinds, _) = splitKindFunTys tc_kind hs_tvs = tcdTyVars decl kinded_tvs = ASSERT( length kinds >= length hs_tvs ) - [ L loc (KindedTyVar (hsTyVarName tv) k) - | (L loc tv, k) <- zip hs_tvs kinds] - ; tcExtendKindEnvTvs kinded_tvs (thing_inside kinded_tvs) } + zipWith add_kind hs_tvs kinds + ; tcExtendKindEnvTvs kinded_tvs thing_inside } + where + add_kind (L loc (UserTyVar n _)) k = L loc (UserTyVar n k) + add_kind (L loc (KindedTyVar n _)) k = L loc (KindedTyVar n k) -- Kind check a data declaration, assuming that we already extended the -- kind environment with the type variables of the left-hand side (these @@ -633,11 +631,13 @@ kcFamilyDecl classTvs decl@(TyFamily {tcdKind = kind}) -- default result kind is '*' } where - unifyClassParmKinds (L _ (KindedTyVar n k)) - | Just classParmKind <- lookup n classTyKinds = unifyKind k classParmKind - | otherwise = return () - unifyClassParmKinds x = pprPanic "kcFamilyDecl/unifyClassParmKinds" (ppr x) - classTyKinds = [(n, k) | L _ (KindedTyVar n k) <- classTvs] + unifyClassParmKinds (L _ tv) + | (n,k) <- hsTyVarNameKind tv + , Just classParmKind <- lookup n classTyKinds + = unifyKind k classParmKind + | otherwise = return () + classTyKinds = [hsTyVarNameKind tv | L _ tv <- classTvs] + kcFamilyDecl _ (TySynonym {}) -- type family defaults = panic "TcTyClsDecls.kcFamilyDecl: not implemented yet" kcFamilyDecl _ d = pprPanic "kcFamilyDecl" (ppr d) @@ -925,11 +925,12 @@ consUseH98Syntax _ = True ------------------- tcConArg :: Bool -- True <=> -funbox-strict_fields -> LHsType Name - -> TcM (TcType, StrictnessMark) + -> TcM (TcType, HsBang) tcConArg unbox_strict bty = do { arg_ty <- tcHsBangType bty ; let bang = getBangStrictness bty - ; return (arg_ty, chooseBoxingStrategy unbox_strict arg_ty bang) } + ; let strict_mark = chooseBoxingStrategy unbox_strict arg_ty bang + ; return (arg_ty, strict_mark) } -- We attempt to unbox/unpack a strict field when either: -- (i) The field is marked '!!', or @@ -937,27 +938,47 @@ tcConArg unbox_strict bty -- -- We have turned off unboxing of newtypes because coercions make unboxing -- and reboxing more complicated -chooseBoxingStrategy :: Bool -> TcType -> HsBang -> StrictnessMark +chooseBoxingStrategy :: Bool -> TcType -> HsBang -> HsBang chooseBoxingStrategy unbox_strict_fields arg_ty bang = case bang of - HsNoBang -> NotMarkedStrict - HsStrict | unbox_strict_fields - && can_unbox arg_ty -> MarkedUnboxed - HsUnbox | can_unbox arg_ty -> MarkedUnboxed - _ -> MarkedStrict + HsNoBang -> HsNoBang + HsUnpack -> can_unbox HsUnpackFailed arg_ty + HsStrict | unbox_strict_fields -> can_unbox HsStrict arg_ty + | otherwise -> HsStrict + HsUnpackFailed -> pprPanic "chooseBoxingStrategy" (ppr arg_ty) + -- Source code never has shtes where - -- we can unbox if the type is a chain of newtypes with a product tycon - -- at the end - can_unbox arg_ty = case splitTyConApp_maybe arg_ty of - Nothing -> False - Just (arg_tycon, tycon_args) -> - not (isRecursiveTyCon arg_tycon) && -- Note [Recusive unboxing] - isProductTyCon arg_tycon && - (if isNewTyCon arg_tycon then - can_unbox (newTyConInstRhs arg_tycon tycon_args) - else True) + can_unbox :: HsBang -> TcType -> HsBang + -- Returns HsUnpack if we can unpack arg_ty + -- fail_bang if we know what arg_ty is but we can't unpack it + -- HsStrict if it's abstract, so we don't know whether or not we can unbox it + can_unbox fail_bang arg_ty + = case splitTyConApp_maybe arg_ty of + Nothing -> fail_bang + + Just (arg_tycon, tycon_args) + | isAbstractTyCon arg_tycon -> HsStrict + -- See Note [Don't complain about UNPACK on abstract TyCons] + | not (isRecursiveTyCon arg_tycon) -- Note [Recusive unboxing] + , isProductTyCon arg_tycon + -- We can unbox if the type is a chain of newtypes + -- with a product tycon at the end + -> if isNewTyCon arg_tycon + then can_unbox fail_bang (newTyConInstRhs arg_tycon tycon_args) + else HsUnpack + + | otherwise -> fail_bang \end{code} +Note [Don't complain about UNPACK on abstract TyCons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We are going to complain about UnpackFailed, but if we say + data T = MkT {-# UNPACK #-} !Wobble +and Wobble is a newtype imported from a module that was compiled +without optimisation, we don't want to complain. Because it might +be fine when optimsation is on. I think this happens when Haddock +is working over (say) GHC souce files. + Note [Recursive unboxing] ~~~~~~~~~~~~~~~~~~~~~~~~~ Be careful not to try to unbox this! @@ -1105,9 +1126,15 @@ checkValidDataCon tc con -- Reason: it's really the argument of an equality constraint ; checkValidType ctxt (dataConUserType con) ; when (isNewTyCon tc) (checkNewDataCon con) + ; mapM_ check_bang (dataConStrictMarks con `zip` [1..]) } where ctxt = ConArgCtxt (dataConName con) + check_bang (HsUnpackFailed, n) = addWarnTc (cant_unbox_msg n) + check_bang _ = return () + + cant_unbox_msg n = sep [ ptext (sLit "Ignoring unusable UNPACK pragma on the") + , speakNth n <+> ptext (sLit "argument of") <+> quotes (ppr con)] ------------------------------- checkNewDataCon :: DataCon -> TcM () @@ -1119,7 +1146,7 @@ checkNewDataCon con -- Return type is (T a b c) ; checkTc (null ex_tvs && null eq_theta && null dict_theta) (newtypeExError con) -- No existentials - ; checkTc (not (any isMarkedStrict (dataConStrictMarks con))) + ; checkTc (not (any isBanged (dataConStrictMarks con))) (newtypeStrictError con) -- No strictness }