added NOUNPACK pragma (see #2338)

compiler/basicTypes/BasicTypes.lhs

@@ -588,6 +588,7 @@ data HsBang = HsNoBang
 	    | HsUnpackFailed   -- An UNPACK pragma that we could not make 
 	      		       -- use of, because the type isn't unboxable; 
                                -- equivalant to HsStrict except for checkValidDataCon
+            | HsNoUnpack       -- {-# NOUNPACK #-} ! (GHC extension, meaning "strict but not unboxed")
   deriving (Eq, Data, Typeable)
 
 instance Outputable HsBang where
@@ -595,6 +596,7 @@ instance Outputable HsBang where
     ppr HsStrict       = char '!'
     ppr HsUnpack       = ptext (sLit "{-# UNPACK #-} !")
     ppr HsUnpackFailed = ptext (sLit "{-# UNPACK (failed) #-} !")
+    ppr HsNoUnpack     = ptext (sLit "{-# NOUNPACK #-} !")
 
 isBanged :: HsBang -> Bool
 isBanged HsNoBang = False

compiler/basicTypes/DataCon.lhs

@@ -952,6 +952,7 @@ computeRep stricts tys
   where
     unbox HsNoBang       ty = [(NotMarkedStrict, ty)]
     unbox HsStrict       ty = [(MarkedStrict,    ty)]
+    unbox HsNoUnpack     ty = [(MarkedStrict,    ty)]
     unbox HsUnpackFailed ty = [(MarkedStrict,    ty)]
     unbox HsUnpack ty = zipEqual "computeRep" (dataConRepStrictness arg_dc) arg_tys
                       where

compiler/iface/BinIface.hs

@@ -773,13 +773,15 @@ instance Binary HsBang where
     put_ bh HsStrict        = putByte bh 1
     put_ bh HsUnpack        = putByte bh 2
     put_ bh HsUnpackFailed  = putByte bh 3
+    put_ bh HsNoUnpack      = putByte bh 4
     get bh = do
 	    h <- getByte bh
 	    case h of
 	      0 -> do return HsNoBang
 	      1 -> do return HsStrict
 	      2 -> do return HsUnpack
-	      _ -> do return HsUnpackFailed
+	      3 -> do return HsUnpackFailed
+              _ -> do return HsNoUnpack
 
 instance Binary TupleSort where
     put_ bh BoxedTuple      = putByte bh 0

compiler/parser/Lexer.x

@@ -477,6 +477,7 @@ data Token
   | ITgenerated_prag
   | ITcore_prag                 -- hdaume: core annotations
   | ITunpack_prag
+  | ITnounpack_prag
   | ITann_prag
   | ITclose_prag
   | IToptions_prag String
@@ -2267,6 +2268,7 @@ oneWordPrags = Map.fromList([("rules", rulePrag),
                            ("generated", token ITgenerated_prag),
                            ("core", token ITcore_prag),
                            ("unpack", token ITunpack_prag),
+                           ("nounpack", token ITnounpack_prag),
                            ("ann", token ITann_prag),
                            ("vectorize", token ITvect_prag),
                            ("novectorize", token ITnovect_prag)])

compiler/parser/Parser.y.pp

@@ -263,6 +263,7 @@ incorrect.
  '{-# DEPRECATED'         { L _ ITdeprecated_prag }
  '{-# WARNING'            { L _ ITwarning_prag }
  '{-# UNPACK'             { L _ ITunpack_prag }
+ '{-# NOUNPACK'           { L _ ITnounpack_prag }
  '{-# ANN'                { L _ ITann_prag }
  '{-# VECTORISE'          { L _ ITvect_prag }
  '{-# VECTORISE_SCALAR'   { L _ ITvect_scalar_prag }
@@ -973,6 +974,7 @@ infixtype :: { LHsType RdrName }
 strict_mark :: { Located HsBang }
         : '!'                           { L1 HsStrict }
         | '{-# UNPACK' '#-}' '!'        { LL HsUnpack }
+        | '{-# NOUNPACK' '#-}' '!'      { LL HsNoUnpack }
 
 -- A ctype is a for-all type
 ctype   :: { LHsType RdrName }

compiler/typecheck/TcTyClsDecls.lhs

@@ -926,6 +926,7 @@ chooseBoxingStrategy arg_ty bang
 	HsStrict -> do { unbox_strict <- doptM Opt_UnboxStrictFields
                        ; if unbox_strict then return (can_unbox HsStrict arg_ty)
                                          else return HsStrict }
+	HsNoUnpack -> return HsStrict
 	HsUnpack -> do { omit_prags <- doptM Opt_OmitInterfacePragmas
             -- Do not respect UNPACK pragmas if OmitInterfacePragmas is on
 	    -- See Trac #5252: unpacking means we must not conceal the

docs/users_guide/glasgow_exts.xml

@@ -8575,6 +8575,26 @@ data S = S {-# UNPACK #-} !Int {-# UNPACK #-} !Int
       constructor field.</para>
     </sect2>
 
+    <sect2 id="nounpack-pragma">
+      <title>NOUNPACK pragma</title>
+
+      <indexterm><primary>NOUNPACK</primary></indexterm>
+
+      <para>The <literal>NOUNPACK</literal> pragma indicates to the compiler
+      that it should not unpack the contents of a constructor field.
+      Example:
+      </para>
+<programlisting>
+data T = T {-# NOUNPACK #-} !(Int,Int)
+</programlisting>
+      <para>
+        Even with the flags
+        <option>-funbox-strict-fields</option> and <option>-O</option>,
+        the field of the constructor <function>T</function> is not
+        unpacked.
+      </para>
+    </sect2>
+
     <sect2 id="source-pragma">
       <title>SOURCE pragma</title>
 

docs/users_guide/using.xml

@@ -1932,7 +1932,12 @@ f "2"    = 2
 	    <para>This option is a bit of a sledgehammer: it might
 	    sometimes make things worse.  Selectively unboxing fields
 	    by using <literal>UNPACK</literal> pragmas might be
-	    better.</para>
+	    better. An alternative is to use
+        <option>-funbox-strict-fields</option> to turn on
+        unboxing by default but disable it for certain constructor
+        fields using the <literal>NOUNPACK</literal> pragma
+        (see <xref linkend="nounpack-pragma"/>).
+        </para>
 	  </listitem>
 	</varlistentry>