From: simonpj@microsoft.com Date: Thu, 6 May 2010 16:33:37 +0000 (+0000) Subject: Fix Trac #3966: warn about useless UNPACK pragmas X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=215ce9f15215399ce30ae55c9521087847d78646;hp=b2d9ef8482638a91e68acdd19ecfe24db0458049 Fix Trac #3966: warn about useless UNPACK pragmas Warning about useless UNPACK pragmas wasn't as easy as I thought. I did quite a bit of refactoring, which improved the code by refining the types somewhat. In particular notice that in DataCon, we have dcStrictMarks :: [HsBang] dcRepStrictness :: [StrictnessMarks] The former relates to the *source-code* annotation, the latter to GHC's representation choice. --- diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 33c6598..41a5fa5 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -54,7 +54,8 @@ module BasicTypes( EP(..), - StrictnessMark(..), isMarkedUnboxed, isMarkedStrict, + HsBang(..), isBanged, isMarkedUnboxed, + StrictnessMark(..), isMarkedStrict, CompilerPhase, Activation(..), isActive, isNeverActive, isAlwaysActive, isEarlyActive, @@ -529,24 +530,46 @@ The strictness annotations on types in data type declarations e.g. data T = MkT !Int !(Bool,Bool) \begin{code} -data StrictnessMark -- Used in interface decls only - = MarkedStrict - | MarkedUnboxed - | NotMarkedStrict - deriving( Eq ) +------------------------- +-- HsBang describes what the *programmer* wrote +-- This info is retained in the DataCon.dcStrictMarks field +data HsBang = HsNoBang -isMarkedUnboxed :: StrictnessMark -> Bool -isMarkedUnboxed MarkedUnboxed = True -isMarkedUnboxed _ = False + | HsStrict -isMarkedStrict :: StrictnessMark -> Bool -isMarkedStrict NotMarkedStrict = False -isMarkedStrict _ = True -- All others are strict + | HsUnpack -- {-# UNPACK #-} ! (GHC extension, meaning "unbox") + + | HsUnpackFailed -- An UNPACK pragma that we could not make + -- use of, because the type isn't unboxable; + -- equivalant to HsStrict except for checkValidDataCon + deriving (Eq, Data, Typeable) + +instance Outputable HsBang where + ppr HsNoBang = empty + ppr HsStrict = char '!' + ppr HsUnpack = ptext (sLit "{-# UNPACK #-} !") + ppr HsUnpackFailed = ptext (sLit "{-# UNPACK (failed) #-} !") + +isBanged :: HsBang -> Bool +isBanged HsNoBang = False +isBanged _ = True + +isMarkedUnboxed :: HsBang -> Bool +isMarkedUnboxed HsUnpack = True +isMarkedUnboxed _ = False + +------------------------- +-- StrictnessMark is internal only, used to indicate strictness +-- of the DataCon *worker* fields +data StrictnessMark = MarkedStrict | NotMarkedStrict instance Outputable StrictnessMark where ppr MarkedStrict = ptext (sLit "!") - ppr MarkedUnboxed = ptext (sLit "!!") - ppr NotMarkedStrict = ptext (sLit "_") + ppr NotMarkedStrict = empty + +isMarkedStrict :: StrictnessMark -> Bool +isMarkedStrict NotMarkedStrict = False +isMarkedStrict _ = True -- All others are strict \end{code} diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index 6c4d583..406d02a 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -327,7 +327,7 @@ data DataCon -- The OrigResTy is T [a], but the dcRepTyCon might be :T123 -- Now the strictness annotations and field labels of the constructor - dcStrictMarks :: [StrictnessMark], + dcStrictMarks :: [HsBang], -- Strictness annotations as decided by the compiler. -- Does *not* include the existential dictionaries -- length = dataConSourceArity dataCon @@ -478,7 +478,7 @@ instance Data.Data DataCon where -- | Build a new data constructor mkDataCon :: Name -> Bool -- ^ Is the constructor declared infix? - -> [StrictnessMark] -- ^ Strictness annotations written in the source file + -> [HsBang] -- ^ Strictness annotations written in the source file -> [FieldLabel] -- ^ Field labels for the constructor, if it is a record, -- otherwise empty -> [TyVar] -- ^ Universally quantified type variables @@ -558,9 +558,9 @@ mkDataCon name declared_infix eqSpecPreds :: [(TyVar,Type)] -> ThetaType eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv, ty) | (tv,ty) <- spec ] -mk_dict_strict_mark :: PredType -> StrictnessMark -mk_dict_strict_mark pred | isStrictPred pred = MarkedStrict - | otherwise = NotMarkedStrict +mk_dict_strict_mark :: PredType -> HsBang +mk_dict_strict_mark pred | isStrictPred pred = HsStrict + | otherwise = HsNoBang \end{code} \begin{code} @@ -663,11 +663,11 @@ dataConFieldType con label -- | The strictness markings decided on by the compiler. Does not include those for -- existential dictionaries. The list is in one-to-one correspondence with the arity of the 'DataCon' -dataConStrictMarks :: DataCon -> [StrictnessMark] +dataConStrictMarks :: DataCon -> [HsBang] dataConStrictMarks = dcStrictMarks -- | Strictness of /existential/ arguments only -dataConExStricts :: DataCon -> [StrictnessMark] +dataConExStricts :: DataCon -> [HsBang] -- Usually empty, so we don't bother to cache this dataConExStricts dc = map mk_dict_strict_mark $ dcDictTheta dc @@ -913,7 +913,7 @@ deepSplitProductType str ty Nothing -> pprPanic (str ++ ": not a product") (pprType ty) -- | Compute the representation type strictness and type suitable for a 'DataCon' -computeRep :: [StrictnessMark] -- ^ Original argument strictness +computeRep :: [HsBang] -- ^ Original argument strictness -> [Type] -- ^ Original argument types -> ([StrictnessMark], -- Representation arg strictness [Type]) -- And type @@ -921,10 +921,11 @@ computeRep :: [StrictnessMark] -- ^ Original argument strictness computeRep stricts tys = unzip $ concat $ zipWithEqual "computeRep" unbox stricts tys where - unbox NotMarkedStrict ty = [(NotMarkedStrict, ty)] - unbox MarkedStrict ty = [(MarkedStrict, ty)] - unbox MarkedUnboxed ty = zipEqual "computeRep" (dataConRepStrictness arg_dc) arg_tys - where - (_tycon, _tycon_args, arg_dc, arg_tys) - = deepSplitProductType "unbox_strict_arg_ty" ty + unbox HsNoBang ty = [(NotMarkedStrict, ty)] + unbox HsStrict ty = [(MarkedStrict, ty)] + unbox HsUnpackFailed ty = [(MarkedStrict, ty)] + unbox HsUnpack ty = zipEqual "computeRep" (dataConRepStrictness arg_dc) arg_tys + where + (_tycon, _tycon_args, arg_dc, arg_tys) + = deepSplitProductType "unbox_strict_arg_ty" ty \end{code} diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 16c45b7..d0725bf 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -244,9 +244,9 @@ mkDataConIds wrap_name wkr_name data_con | isNewTyCon tycon -- Newtype, only has a worker = DCIds Nothing nt_work_id - | any isMarkedStrict all_strict_marks -- Algebraic, needs wrapper - || not (null eq_spec) -- NB: LoadIface.ifaceDeclSubBndrs - || isFamInstTyCon tycon -- depends on this test + | any isBanged all_strict_marks -- Algebraic, needs wrapper + || not (null eq_spec) -- NB: LoadIface.ifaceDeclSubBndrs + || isFamInstTyCon tycon -- depends on this test = DCIds (Just alg_wrap_id) wrk_id | otherwise -- Algebraic, no wrapper @@ -334,8 +334,8 @@ mkDataConIds wrap_name wkr_name data_con all_strict_marks = dataConExStricts data_con ++ dataConStrictMarks data_con wrap_sig = mkStrictSig (mkTopDmdType arg_dmds cpr_info) arg_dmds = map mk_dmd all_strict_marks - mk_dmd str | isMarkedStrict str = evalDmd - | otherwise = lazyDmd + mk_dmd str | isBanged str = evalDmd + | otherwise = lazyDmd -- The Cpr info can be important inside INLINE rhss, where the -- wrapper constructor isn't inlined. -- And the argument strictness can be important too; we @@ -372,23 +372,21 @@ mkDataConIds wrap_name wkr_name data_con in (y:ys,j) mk_case - :: (Id, StrictnessMark) -- Arg, strictness + :: (Id, HsBang) -- Arg, strictness -> (Int -> [Id] -> CoreExpr) -- Body -> Int -- Next rep arg id -> [Id] -- Rep args so far, reversed -> CoreExpr mk_case (arg,strict) body i rep_args = case strict of - NotMarkedStrict -> body i (arg:rep_args) - MarkedStrict - | isUnLiftedType (idType arg) -> body i (arg:rep_args) - | otherwise -> - Case (Var arg) arg res_ty [(DEFAULT,[], body i (arg:rep_args))] - - MarkedUnboxed - -> unboxProduct i (Var arg) (idType arg) the_body + HsNoBang -> body i (arg:rep_args) + HsUnpack -> unboxProduct i (Var arg) (idType arg) the_body where the_body i con_args = body i (reverse con_args ++ rep_args) + _other -- HsUnpackFailed and HsStrict + | isUnLiftedType (idType arg) -> body i (arg:rep_args) + | otherwise -> Case (Var arg) arg res_ty + [(DEFAULT,[], body i (arg:rep_args))] mAX_CPR_SIZE :: Arity mAX_CPR_SIZE = 10 diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index 9b39305..cb06a7f 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -102,17 +102,6 @@ ppr_qq (HsQuasiQuote quoter _ quote) = type LBangType name = Located (BangType name) type BangType name = HsType name -- Bangs are in the HsType data type -data HsBang = HsNoBang -- Only used as a return value for getBangStrictness, - -- never appears on a HsBangTy - | HsStrict -- ! - | HsUnbox -- {-# UNPACK #-} ! (GHC extension, meaning "unbox") - deriving (Data, Typeable) - -instance Outputable HsBang where - ppr (HsNoBang) = empty - ppr (HsStrict) = char '!' - ppr (HsUnbox) = ptext (sLit "!!") - getBangType :: LHsType a -> LHsType a getBangType (L _ (HsBangTy _ ty)) = ty getBangType ty = ty diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 2931ffa..e608421 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -613,16 +613,18 @@ instance Binary InlinePragma where d <- get bh return (InlinePragma a b c d) -instance Binary StrictnessMark where - put_ bh MarkedStrict = putByte bh 0 - put_ bh MarkedUnboxed = putByte bh 1 - put_ bh NotMarkedStrict = putByte bh 2 +instance Binary HsBang where + put_ bh HsNoBang = putByte bh 0 + put_ bh HsStrict = putByte bh 1 + put_ bh HsUnpack = putByte bh 2 + put_ bh HsUnpackFailed = putByte bh 3 get bh = do h <- getByte bh case h of - 0 -> do return MarkedStrict - 1 -> do return MarkedUnboxed - _ -> do return NotMarkedStrict + 0 -> do return HsNoBang + 1 -> do return HsStrict + 2 -> do return HsUnpack + _ -> do return HsUnpackFailed instance Binary Boxity where put_ bh Boxed = putByte bh 0 diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index de1c191..738a5e3 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -191,7 +191,7 @@ setAssocFamilyPermutation _clas_tvs other ------------------------------------------------------ buildDataCon :: Name -> Bool - -> [StrictnessMark] + -> [HsBang] -> [Name] -- Field labels -> [TyVar] -> [TyVar] -- Univ and ext -> [(TyVar,Type)] -- Equality spec @@ -306,7 +306,7 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec ; dict_con <- buildDataCon datacon_name False -- Not declared infix - (map (const NotMarkedStrict) args) + (map (const HsNoBang) args) [{- No fields -}] tvs [{- no existentials -}] [{- No GADT equalities -}] [{- No theta -}] diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index c844d62..44dd34a 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -133,7 +133,7 @@ data IfaceConDecl ifConCtxt :: IfaceContext, -- Non-stupid context ifConArgTys :: [IfaceType], -- Arg types ifConFields :: [OccName], -- ...ditto... (field labels) - ifConStricts :: [StrictnessMark]} -- Empty (meaning all lazy), + ifConStricts :: [HsBang]} -- Empty (meaning all lazy), -- or 1-1 corresp with arg tys data IfaceInst @@ -524,10 +524,13 @@ pprIfaceConDecl tc if is_infix then ptext (sLit "Infix") else empty, if has_wrap then ptext (sLit "HasWrapper") else empty, ppUnless (null strs) $ - nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr strs)), + nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr_bang strs)), ppUnless (null fields) $ nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))] where + ppr_bang HsNoBang = char '_' -- Want to see these + ppr_bang bang = ppr bang + main_payload = ppr name <+> dcolon <+> pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 17d5d2a..ce6f4a3 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -660,6 +660,24 @@ freeNamesDeclExtras IfaceOtherDeclExtras freeNamesSub :: (Fixity,[IfaceRule]) -> NameSet freeNamesSub (_,rules) = unionManyNameSets (map freeNamesIfRule rules) +instance Outputable IfaceDeclExtras where + ppr IfaceOtherDeclExtras = empty + ppr (IfaceIdExtras fix rules) = ppr_id_extras fix rules + ppr (IfaceSynExtras fix) = ppr fix + ppr (IfaceDataExtras fix insts stuff) = vcat [ppr fix, ppr_insts insts, + ppr_id_extras_s stuff] + ppr (IfaceClassExtras fix insts stuff) = vcat [ppr fix, ppr_insts insts, + ppr_id_extras_s stuff] + +ppr_insts :: [IfaceInstABI] -> SDoc +ppr_insts _ = ptext (sLit "") + +ppr_id_extras_s :: [(Fixity, [IfaceRule])] -> SDoc +ppr_id_extras_s stuff = vcat [ppr_id_extras f r | (f,r)<- stuff] + +ppr_id_extras :: Fixity -> [IfaceRule] -> SDoc +ppr_id_extras fix rules = ppr fix $$ vcat (map ppr rules) + -- This instance is used only to compute fingerprints instance Binary IfaceDeclExtras where get _bh = panic "no get for IfaceDeclExtras" diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index d87ffa1..dfa713f 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -197,13 +197,9 @@ pprDataConDecl _ gadt_style show_label dataCon pp_tau = foldr add (ppr res_ty) tys_w_strs add str_ty pp_ty = pprParendBangTy str_ty <+> arrow <+> pp_ty - pprParendBangTy (strict,ty) - | GHC.isMarkedStrict strict = char '!' <> GHC.pprParendType ty - | otherwise = GHC.pprParendType ty + pprParendBangTy (bang,ty) = ppr bang <> GHC.pprParendType ty - pprBangTy strict ty - | GHC.isMarkedStrict strict = char '!' <> ppr ty - | otherwise = ppr ty + pprBangTy bang ty = ppr bang <> ppr ty maybe_show_label (lbl,(strict,tp)) | show_label lbl = Just (ppr lbl <+> dcolon <+> pprBangTy strict tp) diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 42cb96f..37f9ba6 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -936,7 +936,7 @@ infixtype :: { LHsType RdrName } strict_mark :: { Located HsBang } : '!' { L1 HsStrict } - | '{-# UNPACK' '#-}' '!' { LL HsUnbox } + | '{-# UNPACK' '#-}' '!' { LL HsUnpack } -- A ctype is a for-all type ctype :: { LHsType RdrName } diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index 3689479..4695c87 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -72,8 +72,7 @@ import TyCon ( TyCon, AlgTyConRhs(DataTyCon), tyConDataCons, mkTupleTyCon, mkAlgTyCon, tyConName, TyConParent(NoParentTyCon) ) -import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, - StrictnessMark(..) ) +import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, HsBang(..) ) import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTy, mkTyVarTys, TyThing(..) ) @@ -238,7 +237,7 @@ pcDataConWithFixity declared_infix dc_name tyvars arg_tys tycon = data_con where data_con = mkDataCon dc_name declared_infix - (map (const NotMarkedStrict) arg_tys) + (map (const HsNoBang) arg_tys) [] -- No labelled fields tyvars [] -- No existential type variables diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index d5d6b6b..d7118e1 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -1280,7 +1280,7 @@ checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM () checkMissingFields data_con rbinds | null field_labels -- Not declared as a record; -- But C{} is still valid if no strict fields - = if any isMarkedStrict field_strs then + = if any isBanged field_strs then -- Illegal if any arg is strict addErrTc (missingStrictFields data_con []) else @@ -1297,12 +1297,12 @@ checkMissingFields data_con rbinds where missing_s_fields = [ fl | (fl, str) <- field_info, - isMarkedStrict str, + isBanged str, not (fl `elem` field_names_used) ] missing_ns_fields = [ fl | (fl, str) <- field_info, - not (isMarkedStrict str), + not (isBanged str), not (fl `elem` field_names_used) ] diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index d114efb..bafddf8 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -1197,10 +1197,9 @@ reifyFixity name conv_dir BasicTypes.InfixL = TH.InfixL conv_dir BasicTypes.InfixN = TH.InfixN -reifyStrict :: BasicTypes.StrictnessMark -> TH.Strict -reifyStrict MarkedStrict = TH.IsStrict -reifyStrict MarkedUnboxed = TH.IsStrict -reifyStrict NotMarkedStrict = TH.NotStrict +reifyStrict :: BasicTypes.HsBang -> TH.Strict +reifyStrict bang | isBanged bang = TH.IsStrict + | otherwise = TH.NotStrict ------------------------------ noTH :: LitString -> SDoc -> TcM a diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 1261131..47b8c31 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -925,11 +925,11 @@ 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 - ; strict_mark <- 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: @@ -938,31 +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 -> TcM StrictnessMark +chooseBoxingStrategy :: Bool -> TcType -> HsBang -> HsBang chooseBoxingStrategy unbox_strict_fields arg_ty bang = case bang of - HsNoBang -> return NotMarkedStrict - HsUnbox | can_unbox arg_ty -> return MarkedUnboxed - | otherwise -> do { addWarnTc cant_unbox_msg - ; return MarkedStrict } - HsStrict | unbox_strict_fields - , can_unbox arg_ty -> return MarkedUnboxed - _ -> return 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) - - cant_unbox_msg = ptext (sLit "Ignoring unusable UNPACK pragma") + 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! @@ -1110,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 () @@ -1124,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 } diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs index 83fd512..37d65db 100644 --- a/compiler/vectorise/VectType.hs +++ b/compiler/vectorise/VectType.hs @@ -23,7 +23,7 @@ import FamInstEnv ( FamInst, mkLocalFamInst ) import OccName import Id import MkId -import BasicTypes ( StrictnessMark(..), boolToRecFlag, +import BasicTypes ( HsBang(..), boolToRecFlag, alwaysInlinePragma, dfunInlinePragma ) import Var ( Var, TyVar, varType ) import Name ( Name, getOccName ) @@ -202,7 +202,7 @@ vectDataCon dc liftDs $ buildDataCon name' False -- not infix - (map (const NotMarkedStrict) arg_tys) + (map (const HsNoBang) arg_tys) [] -- no labelled fields univ_tvs [] -- no existential tvs for now @@ -693,7 +693,7 @@ buildPDataDataCon orig_name vect_tc repr_tc repr liftDs $ buildDataCon dc_name False -- not infix - (map (const NotMarkedStrict) comp_tys) + (map (const HsNoBang) comp_tys) [] -- no field labels tvs [] -- no existentials