diff options
| -rw-r--r-- | compiler/basicTypes/BasicTypes.lhs | 2 | ||||
| -rw-r--r-- | compiler/basicTypes/DataCon.lhs | 1 | ||||
| -rw-r--r-- | compiler/iface/BinIface.hs | 4 | ||||
| -rw-r--r-- | compiler/parser/Lexer.x | 2 | ||||
| -rw-r--r-- | compiler/parser/Parser.y.pp | 2 | ||||
| -rw-r--r-- | compiler/typecheck/TcTyClsDecls.lhs | 1 | ||||
| -rwxr-xr-x | docs/users_guide/glasgow_exts.xml | 20 | ||||
| -rw-r--r-- | docs/users_guide/using.xml | 7 |
8 files changed, 37 insertions, 2 deletions
diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 1f42d252ce..c6226cac67 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/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 diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index d1716755bf..2e9125ba43 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/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 diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 70e5ebbc18..1c69d20e78 100644 --- a/compiler/iface/BinIface.hs +++ b/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 diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 9ae312c363..c036d74d8d 100644 --- a/compiler/parser/Lexer.x +++ b/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)]) diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 62075e724b..b1c0bbbbe6 100644 --- a/compiler/parser/Parser.y.pp +++ b/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 } diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 7a56db4020..aaa311b8aa 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/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 diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index 5123e1026c..6d1b293701 100755 --- a/docs/users_guide/glasgow_exts.xml +++ b/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> diff --git a/docs/users_guide/using.xml b/docs/users_guide/using.xml index eccd6f967e..4cace1ee88 100644 --- a/docs/users_guide/using.xml +++ b/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> |