Be willing to parse {-# UNPACK #-} without '!'
authorSimon Peyton Jones <simonpj@microsoft.com>
Thu, 10 Jan 2013 16:50:25 +0000 (16:50 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Mon, 14 Jan 2013 16:45:13 +0000 (16:45 +0000)
This change gives a more helpful error message when the
user says    data T = MkT {-# UNPACK #-} Int
which should have a strictness '!' as well. Rather than
just a parse error, we get

  T7562.hs:3:14: Warning:
    UNPACK pragma lacks '!' on the first argument of `MkT'

Fixes Trac #7562

compiler/basicTypes/DataCon.lhs
compiler/basicTypes/MkId.lhs
compiler/deSugar/DsMeta.hs
compiler/hsSyn/Convert.lhs
compiler/iface/MkIface.lhs
compiler/main/PprTyThing.hs
compiler/parser/Parser.y.pp
compiler/typecheck/TcSplice.lhs
compiler/typecheck/TcTyClsDecls.lhs

index e55a6e4..47e37a9 100644 (file)
@@ -442,15 +442,19 @@ data DataConRep
 -- HsBang describes what the *programmer* wrote
 -- This info is retained in the DataCon.dcStrictMarks field
 data HsBang 
-  = HsNoBang          -- Lazy field
+  = HsUserBang   -- The user's source-code request
+       (Maybe Bool)       -- Just True    {-# UNPACK #-}
+                          -- Just False   {-# NOUNPACK #-}
+                          -- Nothing      no pragma
+       Bool               -- True <=> '!' specified
 
-  | HsBang Bool      -- Source-language '!' bang
-                     --  True <=> also an {-# UNPACK #-} pragma
+  | HsNoBang             -- Lazy field
+                          -- HsUserBang Nothing False means the same as HsNoBang
 
   | HsUnpack              -- Definite commitment: this field is strict and unboxed
        (Maybe Coercion)   --    co :: arg-ty ~ product-ty
 
-  | HsStrict            -- Definite commitment: this field is strict but not unboxed
+  | HsStrict              -- Definite commitment: this field is strict but not unboxed
   deriving (Data.Data, Data.Typeable)
 
 -------------------------
@@ -489,7 +493,9 @@ Note [Bangs on data constructor arguments]
 Consider
   data T = MkT !Int {-# UNPACK #-} !Int Bool
 Its dcArgBangs field records the *users* specifications, in this case
-    [HsBang False, HsBang True, HsNoBang]
+    [ HsUserBang Nothing True
+    , HsUserBang (Just True) True
+    , HsNoBang]
 See the declaration of HsBang in BasicTypes
 
 The dcr_bangs field of the dcRep field records the *actual, decided*
@@ -538,12 +544,16 @@ instance Data.Data DataCon where
     dataTypeOf _ = mkNoRepType "DataCon"
 
 instance Outputable HsBang where
-    ppr HsNoBang             = empty
-    ppr (HsBang True)        = ptext (sLit "{-# UNPACK #-} !")
-    ppr (HsBang False)       = char '!'
-    ppr (HsUnpack Nothing)   = ptext (sLit "Unpk")
-    ppr (HsUnpack (Just co)) = ptext (sLit "Unpk") <> parens (ppr co)
-    ppr HsStrict             = ptext (sLit "SrictNotUnpacked")
+    ppr HsNoBang               = empty
+    ppr (HsUserBang prag bang) = pp_unpk prag <+> ppWhen bang (char '!')
+    ppr (HsUnpack Nothing)     = ptext (sLit "Unpk")
+    ppr (HsUnpack (Just co))   = ptext (sLit "Unpk") <> parens (ppr co)
+    ppr HsStrict               = ptext (sLit "SrictNotUnpacked")
+
+pp_unpk :: Maybe Bool -> SDoc
+pp_unpk Nothing      = empty
+pp_unpk (Just True)  = ptext (sLit "{-# UNPACK #-}")
+pp_unpk (Just False) = ptext (sLit "{-# NOUNPACK #-}")
 
 instance Outputable StrictnessMark where
   ppr MarkedStrict     = ptext (sLit "!")
@@ -551,16 +561,16 @@ instance Outputable StrictnessMark where
 
 
 eqHsBang :: HsBang -> HsBang -> Bool
-eqHsBang HsNoBang             HsNoBang             = True
 eqHsBang HsStrict             HsStrict             = True
-eqHsBang (HsBang b1)          (HsBang b2)          = b1 == b2
+eqHsBang (HsUserBang u1 b1)   (HsUserBang u2 b2)   = u1==u2 && b1==b2
 eqHsBang (HsUnpack Nothing)   (HsUnpack Nothing)   = True
 eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2)) = eqType (coercionType c1) (coercionType c2)
 eqHsBang _ _ = False
 
 isBanged :: HsBang -> Bool
-isBanged HsNoBang = False
-isBanged _        = True
+isBanged HsNoBang                  = False
+isBanged (HsUserBang Nothing bang) = bang
+isBanged _                         = True
 
 isMarkedStrict :: StrictnessMark -> Bool
 isMarkedStrict NotMarkedStrict = False
index 1d12f6f..375e731 100644 (file)
@@ -593,7 +593,11 @@ dataConArgRep
 dataConArgRep _ _ arg_ty HsNoBang
   = (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
 
-dataConArgRep dflags fam_envs arg_ty (HsBang user_unpack_prag) 
+dataConArgRep _ _ arg_ty (HsUserBang _ False)  -- No '!'
+  = (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
+
+dataConArgRep dflags fam_envs arg_ty 
+    (HsUserBang unpk_prag True)  -- {-# UNPACK #-} !
   | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas
           -- Don't unpack if we aren't optimising; 
           -- rather arbitrarily, we use -fomit-iface-pragmas
@@ -602,10 +606,11 @@ dataConArgRep dflags fam_envs arg_ty (HsBang user_unpack_prag)
         arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty }
   , isUnpackableType fam_envs arg_ty'
   , (rep_tys, wrappers) <- dataConArgUnpack arg_ty'
-  , user_unpack_prag
-    || gopt Opt_UnboxStrictFields dflags
-    || (gopt Opt_UnboxSmallStrictFields dflags 
-        && length rep_tys <= 1)  -- See Note [Unpack one-wide fields]
+  , case unpk_prag of
+      Nothing -> gopt Opt_UnboxStrictFields dflags
+              || (gopt Opt_UnboxSmallStrictFields dflags 
+                   && length rep_tys <= 1)  -- See Note [Unpack one-wide fields]
+      Just unpack_me -> unpack_me
   = case mb_co of
       Nothing          -> (HsUnpack Nothing,   rep_tys, wrappers)
       Just (co,rep_ty) -> (HsUnpack (Just co), rep_tys, wrapCo co rep_ty wrappers)
@@ -687,6 +692,10 @@ dataConArgUnpack arg_ty
 isUnpackableType :: FamInstEnvs -> Type -> Bool
 -- True if we can unpack the UNPACK fields of the constructor
 -- without involving the NameSet tycons
+-- See Note [Recursive unboxing]
+-- We look "deeply" inside rather than relying on the DataCons
+-- we encounter on the way, because otherwise we might well
+-- end up relying on ourselves!
 isUnpackableType fam_envs ty
   | Just (tc, _) <- splitTyConApp_maybe ty
   , Just con <- tyConSingleDataCon_maybe tc
@@ -695,7 +704,7 @@ isUnpackableType fam_envs ty
   | otherwise
   = False
   where
-    ok_arg tcs (ty, bang) = no_unpack bang || ok_ty tcs norm_ty
+    ok_arg tcs (ty, bang) = not (attempt_unpack bang) || ok_ty tcs norm_ty
         where
           norm_ty = case topNormaliseType fam_envs ty of
                       Just (_, ty) -> ty
@@ -713,10 +722,12 @@ isUnpackableType fam_envs ty
 
     ok_con_args tcs con
        = all (ok_arg tcs) (dataConOrigArgTys con `zip` dataConStrictMarks con)
+         -- NB: dataConStrictMarks gives the *user* request; 
+         -- We'd get a black hole if we used dataConRepBangs
 
-    no_unpack (HsBang True)   = False
-    no_unpack (HsUnpack {})   = False
-    no_unpack _               = True
+    attempt_unpack (HsUnpack {})              = True
+    attempt_unpack (HsUserBang (Just unpk) _) = unpk
+    attempt_unpack _                          = False
 \end{code}
 
 Note [Unpack one-wide fields]
index fd57f46..04ffb76 100644 (file)
@@ -557,8 +557,8 @@ repBangTy ty= do
   rep2 strictTypeName [s, t]
   where
     (str, ty') = case ty of
-                  L _ (HsBangTy (HsBang True) ty) -> (unpackedName,  ty)
-                  L _ (HsBangTy _ ty)             -> (isStrictName,  ty)
+                  L _ (HsBangTy (HsUserBang (Just True) True) ty) -> (unpackedName,  ty)
+                  L _ (HsBangTy (HsUserBang _     True) ty)       -> (isStrictName,  ty)
                   _                               -> (notStrictName, ty)
 
 -------------------------------------------------------
index c5a92f8..a21caf4 100644 (file)
@@ -364,8 +364,8 @@ cvtConstr (ForallC tvs ctxt con)
 
 cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
 cvt_arg (NotStrict, ty) = cvtType ty
-cvt_arg (IsStrict,  ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsBang False) ty' }
-cvt_arg (Unpacked,  ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsBang True)  ty' }
+cvt_arg (IsStrict,  ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsUserBang Nothing     True) ty' }
+cvt_arg (Unpacked,  ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsUserBang (Just True) True) ty' }
 
 cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (ConDeclField RdrName)
 cvt_id_arg (i, str, ty)
index fed30f1..d5b3024 100644 (file)
@@ -1528,7 +1528,7 @@ toIfaceBang _    HsNoBang            = IfNoBang
 toIfaceBang _   (HsUnpack Nothing)   = IfUnpack
 toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (coToIfaceType (tidyCo env co))
 toIfaceBang _   HsStrict             = IfStrict
-toIfaceBang _   (HsBang {})          = panic "toIfaceBang"
+toIfaceBang _   (HsUserBang {})      = panic "toIfaceBang"
 
 classToIfaceDecl :: TidyEnv -> Class -> IfaceDecl
 classToIfaceDecl env clas
index 4447ad5..932b46c 100644 (file)
@@ -217,8 +217,8 @@ pprDataConDecl pefas ss gadt_style dataCon
     -- See Note [Printing bangs on data constructors]
     user_ify :: HsBang -> HsBang
     user_ify bang | opt_PprStyle_Debug = bang
-    user_ify HsStrict                  = HsBang False
-    user_ify (HsUnpack {})             = HsBang True
+    user_ify HsStrict                  = HsUserBang Nothing     True
+    user_ify (HsUnpack {})             = HsUserBang (Just True) True
     user_ify bang                      = bang
 
     maybe_show_label (lbl,bty)
index b613962..c552b6a 100644 (file)
@@ -1030,9 +1030,13 @@ infixtype :: { LHsType RdrName }
         | btype tyvarop  type    { LL $ mkHsOpTy $1 $2 $3 }
 
 strict_mark :: { Located HsBang }
-        : '!'                           { L1 (HsBang False) }
-        | '{-# UNPACK' '#-}' '!'        { LL (HsBang True) }
-        | '{-# NOUNPACK' '#-}' '!'      { LL HsStrict }
+        : '!'                           { L1 (HsUserBang Nothing      True) }
+        | '{-# UNPACK' '#-}'            { LL (HsUserBang (Just True)  False) }
+        | '{-# NOUNPACK' '#-}'          { LL (HsUserBang (Just False) True) }
+        | '{-# UNPACK' '#-}' '!'        { LL (HsUserBang (Just True)  True) }
+        | '{-# NOUNPACK' '#-}' '!'      { LL (HsUserBang (Just False) True) }
+        -- Although UNPAACK with no '!' is illegal, we get a 
+        -- better error message if we parse it here
 
 -- A ctype is a for-all type
 ctype   :: { LHsType RdrName }
index 0a25a6c..959c0c1 100644 (file)
@@ -1487,11 +1487,12 @@ reifyFixity name
       conv_dir BasicTypes.InfixN = TH.InfixN
 
 reifyStrict :: DataCon.HsBang -> TH.Strict
-reifyStrict HsNoBang        = TH.NotStrict
-reifyStrict (HsBang False)  = TH.Unpacked
-reifyStrict (HsBang True)   = TH.Unpacked
-reifyStrict HsStrict        = TH.IsStrict
-reifyStrict (HsUnpack {})   = TH.Unpacked
+reifyStrict HsNoBang                      = TH.NotStrict
+reifyStrict (HsUserBang _ False)          = TH.NotStrict
+reifyStrict (HsUserBang (Just True) True) = TH.Unpacked
+reifyStrict (HsUserBang _     True)       = TH.IsStrict
+reifyStrict HsStrict                      = TH.IsStrict
+reifyStrict (HsUnpack {})                 = TH.Unpacked
 
 ------------------------------
 noTH :: LitString -> SDoc -> TcM a
index 36fcc45..998450a 100644 (file)
@@ -1399,19 +1399,22 @@ checkValidDataCon dflags existential_ok tc con
     }
   where
     ctxt = ConArgCtxt (dataConName con) 
-    check_bang (HsBang want_unpack, rep_bang, n) 
+    check_bang (HsUserBang (Just want_unpack) has_bang, rep_bang, n)
+      | want_unpack, not has_bang
+      = addWarnTc (bad_bang n (ptext (sLit "UNPACK pragma lacks '!'")))
       | want_unpack
       , case rep_bang of { HsUnpack {} -> False; _ -> True }
       , not (gopt Opt_OmitInterfacePragmas dflags)  
            -- If not optimising, se don't unpack, so don't complain!
            -- See MkId.dataConArgRep, the (HsBang True) case
-      = addWarnTc (cant_unbox_msg n)
+      = addWarnTc (bad_bang n (ptext (sLit "Ignoring unusable UNPACK pragma")))
+
     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)]
-
+    bad_bang n herald
+      = hang herald 2 (ptext (sLit "on the") <+> speakNth n 
+                       <+> ptext (sLit "argument of") <+> quotes (ppr con))
 -------------------------------
 checkNewDataCon :: DataCon -> TcM ()
 -- Checks for the data constructor of a newtype