Ticket #2338: 0001-added-NOUNPACK-pragma-see-2338.patch

File 0001-added-NOUNPACK-pragma-see-2338.patch, 7.0 KB (added by StefanWehr, 3 years ago)
  • compiler/basicTypes/BasicTypes.lhs

    From 929ad1a3266f77aafdf59857b516a6b4202d2dad Mon Sep 17 00:00:00 2001
    From: Stefan Wehr <[email protected]>
    Date: Wed, 9 Nov 2011 09:28:57 +0100
    Subject: [PATCH] added NOUNPACK pragma (see #2338)
    
    ---
     compiler/basicTypes/BasicTypes.lhs  |    2 ++
     compiler/basicTypes/DataCon.lhs     |    1 +
     compiler/iface/BinIface.hs          |    4 +++-
     compiler/parser/Lexer.x             |    2 ++
     compiler/parser/Parser.y.pp         |    2 ++
     compiler/typecheck/TcTyClsDecls.lhs |    1 +
     docs/users_guide/glasgow_exts.xml   |   20 ++++++++++++++++++++
     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 1f42d25..c6226ca 100644
    a b data HsBang = HsNoBang 
    588588            | HsUnpackFailed   -- An UNPACK pragma that we could not make  
    589589                               -- use of, because the type isn't unboxable;  
    590590                               -- equivalant to HsStrict except for checkValidDataCon 
     591            | HsNoUnpack       -- {-# NOUNPACK #-} ! (GHC extension, meaning "strict but not unboxed") 
    591592  deriving (Eq, Data, Typeable) 
    592593 
    593594instance Outputable HsBang where 
    instance Outputable HsBang where 
    595596    ppr HsStrict       = char '!' 
    596597    ppr HsUnpack       = ptext (sLit "{-# UNPACK #-} !") 
    597598    ppr HsUnpackFailed = ptext (sLit "{-# UNPACK (failed) #-} !") 
     599    ppr HsNoUnpack     = ptext (sLit "{-# NOUNPACK #-} !") 
    598600 
    599601isBanged :: HsBang -> Bool 
    600602isBanged HsNoBang = False 
  • compiler/basicTypes/DataCon.lhs

    diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs
    index d171675..2e9125b 100644
    a b computeRep stricts tys 
    952952  where 
    953953    unbox HsNoBang       ty = [(NotMarkedStrict, ty)] 
    954954    unbox HsStrict       ty = [(MarkedStrict,    ty)] 
     955    unbox HsNoUnpack     ty = [(MarkedStrict,    ty)] 
    955956    unbox HsUnpackFailed ty = [(MarkedStrict,    ty)] 
    956957    unbox HsUnpack ty = zipEqual "computeRep" (dataConRepStrictness arg_dc) arg_tys 
    957958                      where 
  • compiler/iface/BinIface.hs

    diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
    index 70e5ebb..1c69d20 100644
    a b instance Binary HsBang where 
    773773    put_ bh HsStrict        = putByte bh 1 
    774774    put_ bh HsUnpack        = putByte bh 2 
    775775    put_ bh HsUnpackFailed  = putByte bh 3 
     776    put_ bh HsNoUnpack      = putByte bh 4 
    776777    get bh = do 
    777778            h <- getByte bh 
    778779            case h of 
    779780              0 -> do return HsNoBang 
    780781              1 -> do return HsStrict 
    781782              2 -> do return HsUnpack 
    782               _ -> do return HsUnpackFailed 
     783              3 -> do return HsUnpackFailed 
     784              _ -> do return HsNoUnpack 
    783785 
    784786instance Binary TupleSort where 
    785787    put_ bh BoxedTuple      = putByte bh 0 
  • compiler/parser/Lexer.x

    diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
    index 9ae312c..c036d74 100644
    a b data Token 
    477477  | ITgenerated_prag 
    478478  | ITcore_prag                 -- hdaume: core annotations 
    479479  | ITunpack_prag 
     480  | ITnounpack_prag 
    480481  | ITann_prag 
    481482  | ITclose_prag 
    482483  | IToptions_prag String 
    oneWordPrags = Map.fromList([("rules", rulePrag), 
    22672268                           ("generated", token ITgenerated_prag), 
    22682269                           ("core", token ITcore_prag), 
    22692270                           ("unpack", token ITunpack_prag), 
     2271                           ("nounpack", token ITnounpack_prag), 
    22702272                           ("ann", token ITann_prag), 
    22712273                           ("vectorize", token ITvect_prag), 
    22722274                           ("novectorize", token ITnovect_prag)]) 
  • compiler/parser/Parser.y.pp

    diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
    index 62075e7..b1c0bbb 100644
    a b incorrect. 
    263263 '{-# DEPRECATED'         { L _ ITdeprecated_prag } 
    264264 '{-# WARNING'            { L _ ITwarning_prag } 
    265265 '{-# UNPACK'             { L _ ITunpack_prag } 
     266 '{-# NOUNPACK'           { L _ ITnounpack_prag } 
    266267 '{-# ANN'                { L _ ITann_prag } 
    267268 '{-# VECTORISE'          { L _ ITvect_prag } 
    268269 '{-# VECTORISE_SCALAR'   { L _ ITvect_scalar_prag } 
    infixtype :: { LHsType RdrName } 
    973974strict_mark :: { Located HsBang } 
    974975        : '!'                           { L1 HsStrict } 
    975976        | '{-# UNPACK' '#-}' '!'        { LL HsUnpack } 
     977        | '{-# NOUNPACK' '#-}' '!'      { LL HsNoUnpack } 
    976978 
    977979-- A ctype is a for-all type 
    978980ctype   :: { LHsType RdrName } 
  • compiler/typecheck/TcTyClsDecls.lhs

    diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
    index 7a56db4..aaa311b 100644
    a b chooseBoxingStrategy arg_ty bang 
    926926        HsStrict -> do { unbox_strict <- doptM Opt_UnboxStrictFields 
    927927                       ; if unbox_strict then return (can_unbox HsStrict arg_ty) 
    928928                                         else return HsStrict } 
     929        HsNoUnpack -> return HsStrict 
    929930        HsUnpack -> do { omit_prags <- doptM Opt_OmitInterfacePragmas 
    930931            -- Do not respect UNPACK pragmas if OmitInterfacePragmas is on 
    931932            -- See Trac #5252: unpacking means we must not conceal the 
  • docs/users_guide/glasgow_exts.xml

    diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml
    index 5123e10..6d1b293 100755
    a b data S = S {-# UNPACK #-} !Int {-# UNPACK #-} !Int 
    85758575      constructor field.</para> 
    85768576    </sect2> 
    85778577 
     8578    <sect2 id="nounpack-pragma"> 
     8579      <title>NOUNPACK pragma</title> 
     8580 
     8581      <indexterm><primary>NOUNPACK</primary></indexterm> 
     8582 
     8583      <para>The <literal>NOUNPACK</literal> pragma indicates to the compiler 
     8584      that it should not unpack the contents of a constructor field. 
     8585      Example: 
     8586      </para> 
     8587<programlisting> 
     8588data T = T {-# NOUNPACK #-} !(Int,Int) 
     8589</programlisting> 
     8590      <para> 
     8591        Even with the flags 
     8592        <option>-funbox-strict-fields</option> and <option>-O</option>, 
     8593        the field of the constructor <function>T</function> is not 
     8594        unpacked. 
     8595      </para> 
     8596    </sect2> 
     8597 
    85788598    <sect2 id="source-pragma"> 
    85798599      <title>SOURCE pragma</title> 
    85808600 
  • docs/users_guide/using.xml

    diff --git a/docs/users_guide/using.xml b/docs/users_guide/using.xml
    index eccd6f9..4cace1e 100644
    a b f "2" = 2 
    19321932            <para>This option is a bit of a sledgehammer: it might 
    19331933            sometimes make things worse.  Selectively unboxing fields 
    19341934            by using <literal>UNPACK</literal> pragmas might be 
    1935             better.</para> 
     1935            better. An alternative is to use 
     1936        <option>-funbox-strict-fields</option> to turn on 
     1937        unboxing by default but disable it for certain constructor 
     1938        fields using the <literal>NOUNPACK</literal> pragma 
     1939        (see <xref linkend="nounpack-pragma"/>). 
     1940        </para> 
    19361941          </listitem> 
    19371942        </varlistentry> 
    19381943