Commit 215ce9f1 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

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.
parent b2d9ef84
......@@ -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}
......
......@@ -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}
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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 -}]
......
......@@ -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
......
......@@ -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 "<insts>")
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"
......
......@@ -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)
......
......@@ -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 }
......
......@@ -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
......
......@@ -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)
]
......
......@@ -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
......
......@@ -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
}
......
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment