Rodrigo Mesquita pushed to branch wip/romes/25636 at Glasgow Haskell Compiler / GHC

Commits:

21 changed files:

Changes:

  • compiler/GHC/Builtin/primops.txt.pp
    ... ... @@ -3947,6 +3947,18 @@ primop NewBCOOp "newBCO#" GenPrimOp
    3947 3947 
        effect = ReadWriteEffect
    3948 3948 
        out_of_line      = True
    3949 3949
    3950 
    +primop  NewConAppObjOp "newConAppObj#" GenPrimOp
    3951 
    +   Addr# -> ByteArray# -> Array# a_levpoly -> Word# -> State# s -> (# State# s, b_levpoly #)
    3952 
    +   { @'newConAppObj#' datacon_itbl lits ptrs arity@ creates a new constructor
    3953 
    +     application object on the heap from the info table pointer of the data
    3954 
    +     constructor and the data arguments given in @ptrs@ and @lits@. The
    3955 
    +     resulting object is a heap closure for the constructor application. It is
    3956 
    +     evaluated and properly tagged. The given @arity@ gives the total size of
    3957 
    +     pointers and literals in number of words. }
    3958 
    +   with
    3959 
    +   effect = ReadWriteEffect
    3960 
    +   out_of_line      = True
    3961 
    +
    3950 3962 
     primop  UnpackClosureOp "unpackClosure#" GenPrimOp
    3951 3963 
        a -> (# Addr#, ByteArray#, Array# b #)
    3952 3964 
        { @'unpackClosure#' closure@ copies the closure and pointers in the

  • compiler/GHC/ByteCode/Asm.hs
    ... ... @@ -4,6 +4,7 @@
    4 4 
     {-# LANGUAGE UnboxedTuples   #-}
    5 5 
     {-# LANGUAGE PatternSynonyms   #-}
    6 6 
     {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
    7 
    +{-# LANGUAGE LambdaCase #-}
    7 8 
     --
    8 9 
     --
    9 10 
     --  (c) The University of Glasgow 2002-2006
    ... ... @@ -21,9 +22,9 @@ module GHC.ByteCode.Asm (
    21 22 
             assembleBCO
    22 23 
       ) where
    23 24
    24 
    -import GHC.Prelude hiding ( any )
    25 
    -
    25 
    +import GHC.Prelude hiding ( any, words )
    26 26
    27 
    +import Data.Maybe
    27 28 
     import GHC.ByteCode.Instr
    28 29 
     import GHC.ByteCode.InfoTable
    29 30 
     import GHC.ByteCode.Types
    ... ... @@ -37,9 +38,12 @@ import GHC.Types.SptEntry
    37 38 
     import GHC.Types.Unique.FM
    38 39 
     import GHC.Unit.Types
    39 40
    40 
    -import GHC.Utils.Outputable
    41 
    +import GHC.Utils.Outputable ( Outputable(..), text, (<+>), vcat )
    41 42 
     import GHC.Utils.Panic
    42 43
    44 
    +import GHC.Builtin.Types.Prim ( addrPrimTy )
    45 
    +import GHC.Core.Type          ( isUnliftedType )
    46 
    +import GHC.Core.TyCo.Compare  ( eqType )
    43 47 
     import GHC.Core.TyCon
    44 48 
     import GHC.Data.SizedSeq
    45 49 
     import GHC.Data.SmallArray
    ... ... @@ -66,11 +70,13 @@ import Data.Array.Base ( unsafeWrite )
    66 70 
     import Foreign hiding (shiftL, shiftR)
    67 71 
     import Data.ByteString (ByteString)
    68 72 
     import Data.Char  (ord)
    69 
    -import Data.Maybe (fromMaybe)
    70 73 
     import GHC.Float (castFloatToWord32, castDoubleToWord64)
    71 74
    72 75 
     import qualified Data.List as List ( any )
    73 76 
     import GHC.Exts
    77 
    +import GHC.Core.DataCon
    78 
    +import GHC.Data.FlatBag
    79 
    +import GHC.Types.Id
    74 80
    75 81
    76 82 
     -- -----------------------------------------------------------------------------
    ... ... @@ -83,14 +89,23 @@ import GHC.Exts
    83 89 
     -- defined by this group of BCOs themselves
    84 90 
     bcoFreeNames :: UnlinkedBCO -> UniqDSet Name
    85 91 
     bcoFreeNames bco
    86 
    -  = bco_refs bco `uniqDSetMinusUniqSet` mkNameSet [unlinkedBCOName bco]
    92 
    +  = bco_refs bco
    87 93 
       where
    88 
    -    bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs)
    94 
    +    bco_refs UnlinkedBCO{unlinkedBCOName, unlinkedBCOLits, unlinkedBCOPtrs}
    95 
    +        = unionManyUniqDSets (
    96 
    +             mkUniqDSet [ n | BCOPtrName n <- elemsFlatBag unlinkedBCOPtrs ] :
    97 
    +             mkUniqDSet [ n | BCONPtrItbl n <- elemsFlatBag unlinkedBCOLits ] :
    98 
    +             map bco_refs [ bco | BCOPtrBCO bco <- elemsFlatBag unlinkedBCOPtrs ]
    99 
    +          ) `uniqDSetMinusUniqSet` mkNameSet [unlinkedBCOName]
    100 
    +    bco_refs UnlinkedStaticCon{ unlinkedStaticConName, unlinkedStaticConDataConName
    101 
    +                              , unlinkedStaticConLits, unlinkedStaticConPtrs }
    89 102 
             = unionManyUniqDSets (
    90 
    -             mkUniqDSet [ n | BCOPtrName n <- elemsFlatBag ptrs ] :
    91 
    -             mkUniqDSet [ n | BCONPtrItbl n <- elemsFlatBag nonptrs ] :
    92 
    -             map bco_refs [ bco | BCOPtrBCO bco <- elemsFlatBag ptrs ]
    103 
    +             mkUniqDSet [ unlinkedStaticConDataConName ] :
    104 
    +             mkUniqDSet [ n | BCOPtrName n <- elemsFlatBag unlinkedStaticConPtrs ] :
    105 
    +             mkUniqDSet [ n | BCONPtrItbl n <- elemsFlatBag unlinkedStaticConLits ] :
    106 
    +             map bco_refs [ bco | BCOPtrBCO bco <- elemsFlatBag unlinkedStaticConPtrs ]
    93 107 
               )
    108 
    +          `uniqDSetMinusUniqSet` mkNameSet [ unlinkedStaticConName ]
    94 109
    95 110 
     -- -----------------------------------------------------------------------------
    96 111 
     -- The bytecode assembler
    ... ... @@ -147,9 +162,9 @@ assembleBCOs profile proto_bcos tycons top_strs modbreaks spt_entries = do
    147 162 
     --
    148 163
    149 164 
     data RunAsmReader = RunAsmReader { isn_array :: {-# UNPACK #-} !(Array.IOUArray Int Word16)
    150 
    -                                  , ptr_array :: {-# UNPACK #-} !(SmallMutableArrayIO BCOPtr)
    151 
    -                                  , lit_array :: {-# UNPACK #-} !(SmallMutableArrayIO BCONPtr )
    152 
    -                                  }
    165 
    +                                 , ptr_array :: {-# UNPACK #-} !(SmallMutableArrayIO BCOPtr)
    166 
    +                                 , lit_array :: {-# UNPACK #-} !(SmallMutableArrayIO BCONPtr)
    167 
    +                                 }
    153 168
    154 169 
     data RunAsmResult = RunAsmResult { final_isn_array :: !(Array.UArray Int Word16)
    155 170 
                                      , final_ptr_array :: !(SmallArray BCOPtr)
    ... ... @@ -195,6 +210,40 @@ assembleInspectAsm :: Platform -> BCInstr -> InspectAsm ()
    195 210 
     assembleInspectAsm p i = assembleI @InspectAsm p i
    196 211
    197 212 
     assembleBCO :: Platform -> ProtoBCO -> IO UnlinkedBCO
    213 
    +assembleBCO platform
    214 
    +            (ProtoStaticCon { protoStaticConName
    215 
    +                            , protoStaticCon = dc
    216 
    +                            , protoStaticConData = args
    217 
    +                            }) = do
    218 
    +  let ptrs    = foldr mappendFlatBag emptyFlatBag (mapMaybe idBCOArg args)
    219 
    +  let nonptrs = foldr mappendFlatBag emptyFlatBag (mapMaybe litBCOArg args)
    220 
    +  pure UnlinkedStaticCon
    221 
    +    { unlinkedStaticConName = protoStaticConName
    222 
    +    , unlinkedStaticConDataConName = dataConName dc
    223 
    +    , unlinkedStaticConLits = nonptrs
    224 
    +    , unlinkedStaticConPtrs = ptrs
    225 
    +    , unlinkedStaticConIsUnlifted = isUnliftedType (idType (dataConWrapId dc))
    226 
    +    }
    227 
    +  where
    228 
    +    litBCOArg (Left l) = Just $ case literal platform l of
    229 
    +      OnlyOne np -> unitFlatBag np
    230 
    +      OnlyTwo np1 np2 -> TupleFlatBag np1 np2
    231 
    +    litBCOArg (Right var)
    232 
    +      -- Addr# literals are non-pointers
    233 
    +      | idType var `eqType` addrPrimTy
    234 
    +      = Just $ unitFlatBag (BCONPtrAddr (getName var))
    235 
    +      | otherwise
    236 
    +      = Nothing
    237 
    +
    238 
    +    idBCOArg (Left _) = Nothing
    239 
    +    idBCOArg (Right var)
    240 
    +      | idType var `eqType` addrPrimTy
    241 
    +      = Nothing
    242 
    +      | Just prim <- isPrimOpId_maybe var
    243 
    +      = Just $ unitFlatBag (BCOPtrPrimOp prim)
    244 
    +      | otherwise
    245 
    +      = Just $ unitFlatBag (BCOPtrName (getName var))
    246 
    +
    198 247 
     assembleBCO platform
    199 248 
                 (ProtoBCO { protoBCOName       = nm
    200 249 
                           , protoBCOInstrs     = instrs
    ... ... @@ -561,9 +610,9 @@ oneTwoLength (OnlyTwo {}) = 2
    561 610
    562 611 
     class Monad m => MonadAssembler m where
    563 612 
       ioptr :: IO BCOPtr -> m Word
    564 
    -  lit :: OneOrTwo BCONPtr -> m Word
    613 
    +  lit   :: OneOrTwo BCONPtr -> m Word
    565 614 
       label :: LocalLabel -> m ()
    566 
    -  emit :: PlatformWordSize -> Word16 -> [Operand] -> m ()
    615 
    +  emit  :: PlatformWordSize -> Word16 -> [Operand] -> m ()
    567 616
    568 617 
     lit1 :: MonadAssembler m => BCONPtr -> m Word
    569 618 
     lit1 p = lit (OnlyOne p)
    ... ... @@ -603,20 +652,20 @@ assembleI platform i = case i of
    603 652 
                                                                     tuple_proto
    604 653 
                                      p <- ioptr (liftM BCOPtrBCO ul_bco)
    605 654 
                                      p_tup <- ioptr (liftM BCOPtrBCO ul_tuple_bco)
    606 
    -                                 info <- word (fromIntegral $
    607 
    -                                              mkNativeCallInfoSig platform call_info)
    655 
    +                                 info <- lit $ word $ fromIntegral $
    656 
    +                                              mkNativeCallInfoSig platform call_info
    608 657 
                                      emit_ bci_PUSH_ALTS_T
    609 658 
                                           [Op p, Op info, Op p_tup]
    610 659 
       PUSH_PAD8                -> emit_ bci_PUSH_PAD8 []
    611 660 
       PUSH_PAD16               -> emit_ bci_PUSH_PAD16 []
    612 661 
       PUSH_PAD32               -> emit_ bci_PUSH_PAD32 []
    613 
    -  PUSH_UBX8 lit            -> do np <- literal lit
    662 
    +  PUSH_UBX8 litv           -> do np <- lit $ literal platform litv
    614 663 
                                      emit_ bci_PUSH_UBX8 [Op np]
    615 
    -  PUSH_UBX16 lit           -> do np <- literal lit
    664 
    +  PUSH_UBX16 litv          -> do np <- lit $ literal platform litv
    616 665 
                                      emit_ bci_PUSH_UBX16 [Op np]
    617 
    -  PUSH_UBX32 lit           -> do np <- literal lit
    666 
    +  PUSH_UBX32 litv          -> do np <- lit $ literal platform litv
    618 667 
                                      emit_ bci_PUSH_UBX32 [Op np]
    619 
    -  PUSH_UBX lit nws         -> do np <- literal lit
    668 
    +  PUSH_UBX litv nws        -> do np <- lit $ literal platform litv
    620 669 
                                      emit_ bci_PUSH_UBX [Op np, wOp nws]
    621 670 
       -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode
    622 671 
       PUSH_ADDR nm             -> do np <- lit1 (BCONPtrAddr nm)
    ... ... @@ -644,53 +693,53 @@ assembleI platform i = case i of
    644 693 
       PACK      dcon sz        -> do itbl_no <- lit1 (BCONPtrItbl (getName dcon))
    645 694 
                                      emit_ bci_PACK [Op itbl_no, wOp sz]
    646 695 
       LABEL     lbl            -> label lbl
    647 
    -  TESTLT_I  i l            -> do np <- int i
    696 
    +  TESTLT_I  i l            -> do np <- lit $ int i
    648 697 
                                      emit_ bci_TESTLT_I [Op np, LabelOp l]
    649 
    -  TESTEQ_I  i l            -> do np <- int i
    698 
    +  TESTEQ_I  i l            -> do np <- lit $ int i
    650 699 
                                      emit_ bci_TESTEQ_I [Op np, LabelOp l]
    651 
    -  TESTLT_W  w l            -> do np <- word w
    700 
    +  TESTLT_W  w l            -> do np <- lit $ word w
    652 701 
                                      emit_ bci_TESTLT_W [Op np, LabelOp l]
    653 
    -  TESTEQ_W  w l            -> do np <- word w
    702 
    +  TESTEQ_W  w l            -> do np <- lit $ word w
    654 703 
                                      emit_ bci_TESTEQ_W [Op np, LabelOp l]
    655 
    -  TESTLT_I64  i l          -> do np <- word64 (fromIntegral i)
    704 
    +  TESTLT_I64  i l          -> do np <- lit $ word64 platform (fromIntegral i)
    656 705 
                                      emit_ bci_TESTLT_I64 [Op np, LabelOp l]
    657 
    -  TESTEQ_I64  i l          -> do np <- word64 (fromIntegral i)
    706 
    +  TESTEQ_I64  i l          -> do np <- lit $ word64 platform (fromIntegral i)
    658 707 
                                      emit_ bci_TESTEQ_I64 [Op np, LabelOp l]
    659 
    -  TESTLT_I32  i l          -> do np <- word (fromIntegral i)
    708 
    +  TESTLT_I32  i l          -> do np <- lit $ word (fromIntegral i)
    660 709 
                                      emit_ bci_TESTLT_I32 [Op np, LabelOp l]
    661 
    -  TESTEQ_I32 i l           -> do np <- word (fromIntegral i)
    710 
    +  TESTEQ_I32 i l           -> do np <- lit $ word (fromIntegral i)
    662 711 
                                      emit_ bci_TESTEQ_I32 [Op np, LabelOp l]
    663 
    -  TESTLT_I16  i l          -> do np <- word (fromIntegral i)
    712 
    +  TESTLT_I16  i l          -> do np <- lit $ word (fromIntegral i)
    664 713 
                                      emit_ bci_TESTLT_I16 [Op np, LabelOp l]
    665 
    -  TESTEQ_I16 i l           -> do np <- word (fromIntegral i)
    714 
    +  TESTEQ_I16 i l           -> do np <- lit $ word (fromIntegral i)
    666 715 
                                      emit_ bci_TESTEQ_I16 [Op np, LabelOp l]
    667 
    -  TESTLT_I8  i l           -> do np <- word (fromIntegral i)
    716 
    +  TESTLT_I8  i l           -> do np <- lit $ word (fromIntegral i)
    668 717 
                                      emit_ bci_TESTLT_I8 [Op np, LabelOp l]
    669 
    -  TESTEQ_I8 i l            -> do np <- word (fromIntegral i)
    718 
    +  TESTEQ_I8 i l            -> do np <- lit $ word (fromIntegral i)
    670 719 
                                      emit_ bci_TESTEQ_I8 [Op np, LabelOp l]
    671 
    -  TESTLT_W64  w l          -> do np <- word64 w
    720 
    +  TESTLT_W64  w l          -> do np <- lit $ word64 platform w
    672 721 
                                      emit_ bci_TESTLT_W64 [Op np, LabelOp l]
    673 
    -  TESTEQ_W64  w l          -> do np <- word64 w
    722 
    +  TESTEQ_W64  w l          -> do np <- lit $ word64 platform w
    674 723 
                                      emit_ bci_TESTEQ_W64 [Op np, LabelOp l]
    675 
    -  TESTLT_W32  w l          -> do np <- word (fromIntegral w)
    724 
    +  TESTLT_W32  w l          -> do np <- lit $ word (fromIntegral w)
    676 725 
                                      emit_ bci_TESTLT_W32 [Op np, LabelOp l]
    677 
    -  TESTEQ_W32  w l          -> do np <- word (fromIntegral w)
    726 
    +  TESTEQ_W32  w l          -> do np <- lit $ word (fromIntegral w)
    678 727 
                                      emit_ bci_TESTEQ_W32 [Op np, LabelOp l]
    679 
    -  TESTLT_W16  w l          -> do np <- word (fromIntegral w)
    728 
    +  TESTLT_W16  w l          -> do np <- lit $ word (fromIntegral w)
    680 729 
                                      emit_ bci_TESTLT_W16 [Op np, LabelOp l]
    681 
    -  TESTEQ_W16  w l          -> do np <- word (fromIntegral w)
    730 
    +  TESTEQ_W16  w l          -> do np <- lit $ word (fromIntegral w)
    682 731 
                                      emit_ bci_TESTEQ_W16 [Op np, LabelOp l]
    683 
    -  TESTLT_W8  w l           -> do np <- word (fromIntegral w)
    732 
    +  TESTLT_W8  w l           -> do np <- lit $ word (fromIntegral w)
    684 733 
                                      emit_ bci_TESTLT_W8 [Op np, LabelOp l]
    685 
    -  TESTEQ_W8  w l           -> do np <- word (fromIntegral w)
    734 
    +  TESTEQ_W8  w l           -> do np <- lit $ word (fromIntegral w)
    686 735 
                                      emit_ bci_TESTEQ_W8 [Op np, LabelOp l]
    687 
    -  TESTLT_F  f l            -> do np <- float f
    736 
    +  TESTLT_F  f l            -> do np <- lit $ float platform f
    688 737 
                                      emit_ bci_TESTLT_F [Op np, LabelOp l]
    689 
    -  TESTEQ_F  f l            -> do np <- float f
    738 
    +  TESTEQ_F  f l            -> do np <- lit $ float platform f
    690 739 
                                      emit_ bci_TESTEQ_F [Op np, LabelOp l]
    691 
    -  TESTLT_D  d l            -> do np <- double d
    740 
    +  TESTLT_D  d l            -> do np <- lit $ double platform d
    692 741 
                                      emit_ bci_TESTLT_D [Op np, LabelOp l]
    693 
    -  TESTEQ_D  d l            -> do np <- double d
    742 
    +  TESTEQ_D  d l            -> do np <- lit $ double platform d
    694 743 
                                      emit_ bci_TESTEQ_D [Op np, LabelOp l]
    695 744 
       TESTLT_P  i l            -> emit_ bci_TESTLT_P [SmallOp i, LabelOp l]
    696 745 
       TESTEQ_P  i l            -> emit_ bci_TESTEQ_P [SmallOp i, LabelOp l]
    ... ... @@ -864,84 +913,86 @@ assembleI platform i = case i of
    864 913
    865 914 
       where
    866 915 
         unsupported_width = panic "GHC.ByteCode.Asm: Unsupported Width"
    867 
    -    emit_ = emit word_size
    868 
    -
    869 
    -    literal :: Literal -> m Word
    870 
    -    literal (LitLabel fs _)   = litlabel fs
    871 
    -    literal LitNullAddr       = word 0
    872 
    -    literal (LitFloat r)      = float (fromRational r)
    873 
    -    literal (LitDouble r)     = double (fromRational r)
    874 
    -    literal (LitChar c)       = int (ord c)
    875 
    -    literal (LitString bs)    = lit1 (BCONPtrStr bs)
    876 
    -       -- LitString requires a zero-terminator when emitted
    877 
    -    literal (LitNumber nt i) = case nt of
    878 
    -      LitNumInt     -> word (fromIntegral i)
    879 
    -      LitNumWord    -> word (fromIntegral i)
    880 
    -      LitNumInt8    -> word8 (fromIntegral i)
    881 
    -      LitNumWord8   -> word8 (fromIntegral i)
    882 
    -      LitNumInt16   -> word16 (fromIntegral i)
    883 
    -      LitNumWord16  -> word16 (fromIntegral i)
    884 
    -      LitNumInt32   -> word32 (fromIntegral i)
    885 
    -      LitNumWord32  -> word32 (fromIntegral i)
    886 
    -      LitNumInt64   -> word64 (fromIntegral i)
    887 
    -      LitNumWord64  -> word64 (fromIntegral i)
    888 
    -      LitNumBigNat  -> panic "GHC.ByteCode.Asm.literal: LitNumBigNat"
    916 
    +    emit_ = emit (platformWordSize platform)
    917 
    +
    918 
    +literal :: Platform -> Literal -> OneOrTwo BCONPtr
    919 
    +literal platform = \case
    920 
    +  LitLabel fs _  -> OnlyOne (BCONPtrLbl fs)
    921 
    +  LitNullAddr    -> word 0
    922 
    +  LitFloat r     -> float platform (fromRational r)
    923 
    +  LitDouble r    -> double platform (fromRational r)
    924 
    +  LitChar c      -> int (ord c)
    925 
    +  LitString bs   -> OnlyOne (BCONPtrStr bs)
    926 
    +   -- LitString requires a zero-terminator when emitted
    927 
    +  LitNumber nt i -> case nt of
    928 
    +    LitNumInt     -> word (fromIntegral i)
    929 
    +    LitNumWord    -> word (fromIntegral i)
    930 
    +    LitNumInt8    -> word8  platform (fromIntegral i)
    931 
    +    LitNumWord8   -> word8  platform (fromIntegral i)
    932 
    +    LitNumInt16   -> word16 platform (fromIntegral i)
    933 
    +    LitNumWord16  -> word16 platform (fromIntegral i)
    934 
    +    LitNumInt32   -> word32 platform (fromIntegral i)
    935 
    +    LitNumWord32  -> word32 platform (fromIntegral i)
    936 
    +    LitNumInt64   -> word64 platform (fromIntegral i)
    937 
    +    LitNumWord64  -> word64 platform (fromIntegral i)
    938 
    +    LitNumBigNat  -> panic "GHC.ByteCode.Asm.literal: LitNumBigNat"
    889 939
    890 940 
         -- We can lower 'LitRubbish' to an arbitrary constant, but @NULL@ is most
    891 941 
         -- likely to elicit a crash (rather than corrupt memory) in case absence
    892 942 
         -- analysis messed up.
    893 
    -    literal (LitRubbish {}) = word 0
    894 
    -
    895 
    -    litlabel fs = lit1 (BCONPtrLbl fs)
    896 
    -    words ws = lit (fmap BCONPtrWord ws)
    897 
    -    word w = words (OnlyOne w)
    898 
    -    word2 w1 w2 = words (OnlyTwo w1 w2)
    899 
    -    word_size  = platformWordSize platform
    900 
    -    word_size_bits = platformWordSizeInBits platform
    901 
    -
    902 
    -    -- Make lists of host-sized words for literals, so that when the
    903 
    -    -- words are placed in memory at increasing addresses, the
    904 
    -    -- bit pattern is correct for the host's word size and endianness.
    905 
    -    --
    906 
    -    -- Note that we only support host endianness == target endianness for now,
    907 
    -    -- even with the external interpreter. This would need to be fixed to
    908 
    -    -- support host endianness /= target endianness
    909 
    -    int :: Int -> m Word
    910 
    -    int  i = word (fromIntegral i)
    911 
    -
    912 
    -    float :: Float -> m Word
    913 
    -    float f = word32 (castFloatToWord32 f)
    914 
    -
    915 
    -    double :: Double -> m Word
    916 
    -    double d = word64 (castDoubleToWord64 d)
    917 
    -
    918 
    -    word64 :: Word64 -> m Word
    919 
    -    word64 ww = case word_size of
    920 
    -       PW4 ->
    921 
    -        let !wl = fromIntegral ww
    922 
    -            !wh = fromIntegral (ww `unsafeShiftR` 32)
    923 
    -        in case platformByteOrder platform of
    924 
    -            LittleEndian -> word2 wl wh
    925 
    -            BigEndian    -> word2 wh wl
    926 
    -       PW8 -> word (fromIntegral ww)
    927 
    -
    928 
    -    word8 :: Word8 -> m Word
    929 
    -    word8  x = case platformByteOrder platform of
    930 
    -      LittleEndian -> word (fromIntegral x)
    931 
    -      BigEndian    -> word (fromIntegral x `unsafeShiftL` (word_size_bits - 8))
    932 
    -
    933 
    -    word16 :: Word16 -> m Word
    934 
    -    word16 x = case platformByteOrder platform of
    935 
    -      LittleEndian -> word (fromIntegral x)
    936 
    -      BigEndian    -> word (fromIntegral x `unsafeShiftL` (word_size_bits - 16))
    937 
    -
    938 
    -    word32 :: Word32 -> m Word
    939 
    -    word32 x = case platformByteOrder platform of
    940 
    -      LittleEndian -> word (fromIntegral x)
    941 
    -      BigEndian    -> case word_size of
    942 
    -        PW4 -> word (fromIntegral x)
    943 
    -        PW8 -> word (fromIntegral x `unsafeShiftL` 32)
    943 
    +  LitRubbish {} -> word 0
    944 
    +
    945 
    +words :: OneOrTwo Word -> OneOrTwo BCONPtr
    946 
    +words ws = fmap BCONPtrWord ws
    947 
    +
    948 
    +word :: Word -> OneOrTwo BCONPtr
    949 
    +word w = words (OnlyOne w)
    944 950
    951 
    +word2 :: Word -> Word -> OneOrTwo BCONPtr
    952 
    +word2 w1 w2 = words (OnlyTwo w1 w2)
    953 
    +
    954 
    +-- Make lists of host-sized words for literals, so that when the
    955 
    +-- words are placed in memory at increasing addresses, the
    956 
    +-- bit pattern is correct for the host's word size and endianness.
    957 
    +--
    958 
    +-- Note that we only support host endianness == target endianness for now,
    959 
    +-- even with the external interpreter. This would need to be fixed to
    960 
    +-- support host endianness /= target endianness
    961 
    +int :: Int -> OneOrTwo BCONPtr
    962 
    +int i = word (fromIntegral i)
    963 
    +
    964 
    +float :: Platform -> Float -> OneOrTwo BCONPtr
    965 
    +float platform f = word32 platform (castFloatToWord32 f)
    966 
    +
    967 
    +double :: Platform -> Double -> OneOrTwo BCONPtr
    968 
    +double p d = word64 p (castDoubleToWord64 d)
    969 
    +
    970 
    +word64 :: Platform -> Word64 -> OneOrTwo BCONPtr
    971 
    +word64 platform ww = case platformWordSize platform of
    972 
    +   PW4 ->
    973 
    +    let !wl = fromIntegral ww
    974 
    +        !wh = fromIntegral (ww `unsafeShiftR` 32)
    975 
    +    in case platformByteOrder platform of
    976 
    +        LittleEndian -> word2 wl wh
    977 
    +        BigEndian    -> word2 wh wl
    978 
    +   PW8 -> word (fromIntegral ww)
    979 
    +
    980 
    +word8 :: Platform -> Word8 -> OneOrTwo BCONPtr
    981 
    +word8 platform x = case platformByteOrder platform of
    982 
    +  LittleEndian -> word (fromIntegral x)
    983 
    +  BigEndian    -> word (fromIntegral x `unsafeShiftL` (platformWordSizeInBits platform - 8))
    984 
    +
    985 
    +word16 :: Platform -> Word16 -> OneOrTwo BCONPtr
    986 
    +word16 platform x = case platformByteOrder platform of
    987 
    +  LittleEndian -> word (fromIntegral x)
    988 
    +  BigEndian    -> word (fromIntegral x `unsafeShiftL` (platformWordSizeInBits platform - 16))
    989 
    +
    990 
    +word32 :: Platform -> Word32 -> OneOrTwo BCONPtr
    991 
    +word32 platform x = case platformByteOrder platform of
    992 
    +  LittleEndian -> word (fromIntegral x)
    993 
    +  BigEndian    -> case platformWordSize platform of
    994 
    +    PW4 -> word (fromIntegral x)
    995 
    +    PW8 -> word (fromIntegral x `unsafeShiftL` 32)
    945 996
    946 997 
     isLargeW :: Word -> Bool
    947 998 
     isLargeW n = n > 65535

  • compiler/GHC/ByteCode/Instr.hs
    ... ... @@ -16,6 +16,7 @@ import GHC.Cmm.Type (Width)
    16 16 
     import GHC.StgToCmm.Layout     ( ArgRep(..) )
    17 17 
     import GHC.Utils.Outputable
    18 18 
     import GHC.Types.Name
    19 
    +import GHC.Types.Id
    19 20 
     import GHC.Types.Literal
    20 21 
     import GHC.Types.Unique
    21 22 
     import GHC.Core.DataCon
    ... ... @@ -43,9 +44,63 @@ data ProtoBCO
    43 44 
             protoBCOBitmap     :: [StgWord],
    44 45 
             protoBCOBitmapSize :: Word,
    45 46 
             protoBCOArity      :: Int,
    46 
    -        -- what the BCO came from, for debugging only
    47 
    +        -- | What the BCO came from, for debugging only
    47 48 
             protoBCOExpr       :: Either [CgStgAlt] CgStgRhs
    48 49 
        }
    50 
    +   -- | A top-level static constructor application object
    51 
    +   -- See Note [Static constructors in Bytecode]
    52 
    +   | ProtoStaticCon {
    53 
    +        protoStaticConName :: Name,
    54 
    +        -- ^ The name to which this static constructor is bound,
    55 
    +        -- not to be confused with the DataCon itself.
    56 
    +        protoStaticCon     :: DataCon,
    57 
    +        -- ^ The DataCon being constructed.
    58 
    +        -- We use this to construct the right info table.
    59 
    +        protoStaticConData :: [Either Literal Id],
    60 
    +        -- ^ The static constructor pointer and non-pointer arguments, sorted
    61 
    +        -- in the order they should appear at runtime (see 'mkVirtConstrOffsets').
    62 
    +        -- The pointers always come first, followed by the non-pointers.
    63 
    +        protoStaticConExpr :: CgStgRhs
    64 
    +        -- ^ What the static con came from, for debugging only
    65 
    +   }
    66 
    +
    67 
    +{-
    68 
    +Note [Static constructors in Bytecode]
    69 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    70 
    +In bytecode, top-level 'StgRhsCon's are lowered to 'ProtoStaticCon' rather than
    71 
    +'ProtoBCO'. A 'ProtoStaticCon' represents directly a heap allocated data
    72 
    +constructor application. We can do this only for top-level 'StgRhsCon's, where
    73 
    +all the data arguments to the constructor are statically known.
    74 
    +
    75 
    +'StgRhsCon's which have free variables are compiled down to BCOs which push the
    76 
    +arguments and then 'PACK' the constructor, just like 'StgConApp's.
    77 
    +
    78 
    +Example:
    79 
    +
    80 
    +  Haskell:
    81 
    +
    82 
    +    data X = X Char# Char
    83 
    +    x = X 'a'# 'b'
    84 
    +
    85 
    +  Stg:
    86 
    +
    87 
    +    x1  = GHC.Types.C#! ['b'#];
    88 
    +    X.x = X.X! ['a#' x2];
    89 
    +
    90 
    +    X.X = \r [arg1 arg2] X.X [arg1 arg2];
    91 
    +
    92 
    +  ByteCode:
    93 
    +    ProtoStaticCon x1:
    94 
    +      C# [Left 'b'#]
    95 
    +    ProtoStaticCon X.x:
    96 
    +      X.X [Left 'a'#, Right x1]
    97 
    +
    98 
    +    ProtoBCO X.X:
    99 
    +     PUSH_LL  0 1
    100 
    +     PACK     X.X 2
    101 
    +     SLIDE    1 2
    102 
    +     RETURN   P
    103 
    +-}
    49 104
    50 105 
     -- | A local block label (e.g. identifying a case alternative).
    51 106 
     newtype LocalLabel = LocalLabel { getLocalLabel :: Word32 }
    ... ... @@ -278,6 +333,11 @@ data BCInstr
    278 333 
     -- Printing bytecode instructions
    279 334
    280 335 
     instance Outputable ProtoBCO where
    336 
    +   ppr (ProtoStaticCon nm con args origin)
    337 
    +      = text "ProtoStaticCon" <+> ppr nm <> colon
    338 
    +        $$ nest 3 (pprStgRhsShort shortStgPprOpts origin)
    339 
    +        $$ nest 3 (text "constructor: "  <+> ppr con)
    340 
    +        $$ nest 3 (text "sorted args: "  <+> ppr args)
    281 341 
        ppr (ProtoBCO { protoBCOName       = name
    282 342 
                      , protoBCOInstrs     = instrs
    283 343 
                      , protoBCOBitmap     = bitmap
    ... ... @@ -469,7 +529,8 @@ instance Outputable BCInstr where
    469 529 
     -- stack high water mark, but it doesn't seem worth the hassle.
    470 530
    471 531 
     protoBCOStackUse :: ProtoBCO -> Word
    472 
    -protoBCOStackUse bco = sum (map bciStackUse (protoBCOInstrs bco))
    532 
    +protoBCOStackUse ProtoBCO{protoBCOInstrs} = sum (map bciStackUse protoBCOInstrs)
    533 
    +protoBCOStackUse ProtoStaticCon{} = 0
    473 534
    474 535 
     bciStackUse :: BCInstr -> Word
    475 536 
     bciStackUse STKCHECK{}            = 0

  • compiler/GHC/ByteCode/Linker.hs
    ... ... @@ -12,6 +12,7 @@ module GHC.ByteCode.Linker
    12 12 
       , lookupStaticPtr
    13 13 
       , lookupIE
    14 14 
       , linkFail
    15 
    +  , BCOIx(..)
    15 16 
       )
    16 17 
     where
    17 18
    ... ... @@ -46,31 +47,68 @@ import Data.Array.Unboxed
    46 47 
     import Foreign.Ptr
    47 48 
     import GHC.Exts
    48 49
    49 
    -{-
    50 
    +{- |
    50 51 
       Linking interpretables into something we can run
    51 52 
     -}
    52 
    -
    53 53 
     linkBCO
    54 54 
       :: Interp
    55 55 
       -> PkgsLoaded
    56 56 
       -> BytecodeLoaderState
    57 
    -  -> NameEnv Int
    57 
    +  -> NameEnv BCOIx
    58 
    +  -- ^ A mapping from names to references to other BCOs
    59 
    +  --   or static constructors in this group.
    58 60 
       -> UnlinkedBCO
    59 61 
       -> IO ResolvedBCO
    60 
    -linkBCO interp pkgs_loaded bytecode_state bco_ix
    61 
    -           (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do
    62 
    -  -- fromIntegral Word -> Word64 should be a no op if Word is Word64
    63 
    -  -- otherwise it will result in a cast to longlong on 32bit systems.
    64 
    -  (lits :: [Word]) <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded bytecode_state) (elemsFlatBag lits0)
    65 
    -  ptrs <- mapM (resolvePtr interp pkgs_loaded bytecode_state bco_ix) (elemsFlatBag ptrs0)
    66 
    -  let lits' = listArray (0 :: Int, fromIntegral (sizeFlatBag lits0)-1) lits
    67 
    -  return $ ResolvedBCO { resolvedBCOIsLE   = isLittleEndian
    68 
    -                       , resolvedBCOArity  = arity
    69 
    -                       , resolvedBCOInstrs = insns
    70 
    -                       , resolvedBCOBitmap = bitmap
    71 
    -                       , resolvedBCOLits   = mkBCOByteArray lits'
    72 
    -                       , resolvedBCOPtrs   = addListToSS emptySS ptrs
    73 
    -                       }
    62 
    +linkBCO interp pkgs_loaded bytecode_state bco_ix unl_bco = do
    63 
    +  case unl_bco of
    64 
    +    UnlinkedBCO _ arity insns
    65 
    +           bitmap lits0 ptrs0 -> do
    66 
    +        lits <- doLits lits0
    67 
    +        ptrs <- doPtrs ptrs0
    68 
    +        return ResolvedBCO
    69 
    +          { resolvedBCOIsLE   = isLittleEndian
    70 
    +          , resolvedBCOArity  = arity
    71 
    +          , resolvedBCOInstrs = insns
    72 
    +          , resolvedBCOBitmap = bitmap
    73 
    +          , resolvedBCOLits   = lits
    74 
    +          , resolvedBCOPtrs   = ptrs
    75 
    +          }
    76 
    +
    77 
    +    UnlinkedStaticCon
    78 
    +      { unlinkedStaticConLits = lits0
    79 
    +      , unlinkedStaticConPtrs = ptrs0
    80 
    +      , unlinkedStaticConDataConName
    81 
    +      , unlinkedStaticConIsUnlifted
    82 
    +      } -> do
    83 
    +        Ptr itbl_ptr# <- lookupIE interp pkgs_loaded bytecode_state unlinkedStaticConDataConName
    84 
    +        lits <- doLits lits0
    85 
    +        ptrs <- doPtrs ptrs0
    86 
    +        return ResolvedStaticCon
    87 
    +          { resolvedBCOIsLE = isLittleEndian
    88 
    +          , resolvedStaticConInfoPtr = W# (int2Word# (addr2Int# itbl_ptr#))
    89 
    +          , resolvedStaticConArity = sizeFlatBag lits0 + sizeFlatBag ptrs0
    90 
    +          , resolvedStaticConLits = lits
    91 
    +          , resolvedStaticConPtrs = ptrs
    92 
    +          , resolvedStaticConIsUnlifted = unlinkedStaticConIsUnlifted
    93 
    +          }
    94 
    +  where
    95 
    +    doLits lits0 = do
    96 
    +      (lits :: [Word]) <- mapM (lookupLiteral interp pkgs_loaded bytecode_state) (elemsFlatBag lits0)
    97 
    +      let lits' = listArray (0 :: Int, fromIntegral (sizeFlatBag lits0)-1) lits
    98 
    +      return $ mkBCOByteArray lits'
    99 
    +    doPtrs ptrs0 = addListToSS emptySS <$> do
    100 
    +      mapM (resolvePtr interp pkgs_loaded bytecode_state bco_ix) (elemsFlatBag ptrs0)
    101 
    +
    102 
    +-- | An index into a BCO or Static Constructor in this group.
    103 
    +--
    104 
    +-- We distinguish between lifted and unlifted static constructors because
    105 
    +-- lifted ones get resolved by tying a knot, since there may be circular
    106 
    +-- dependencies between them, whereas unlifted ones get constructed in a first
    107 
    +-- pass.
    108 
    +data BCOIx = BCOIx !Int
    109 
    +           | LiftedStaticConIx !Int
    110 
    +           | UnliftedStaticConIx !Int
    111 
    +  deriving (Eq, Ord, Show)
    74 112
    75 113 
     lookupLiteral :: Interp -> PkgsLoaded -> BytecodeLoaderState -> BCONPtr -> IO Word
    76 114 
     lookupLiteral interp pkgs_loaded bytecode_state ptr = case ptr of
    ... ... @@ -154,13 +192,16 @@ resolvePtr
    154 192 
       :: Interp
    155 193 
       -> PkgsLoaded
    156 194 
       -> BytecodeLoaderState
    157 
    -  -> NameEnv Int
    195 
    +  -> NameEnv BCOIx
    158 196 
       -> BCOPtr
    159 197 
       -> IO ResolvedBCOPtr
    160 198 
     resolvePtr interp pkgs_loaded bco_loader_state bco_ix ptr = case ptr of
    161 199 
       BCOPtrName nm
    162 
    -    | Just ix <- lookupNameEnv bco_ix nm
    163 
    -    -> return (ResolvedBCORef ix) -- ref to another BCO in this group
    200 
    +    | Just bix <- lookupNameEnv bco_ix nm
    201 
    +    -> return $ case bix of
    202 
    +        BCOIx ix               -> ResolvedBCORef ix
    203 
    +        LiftedStaticConIx ix   -> ResolvedStaticConRef ix
    204 
    +        UnliftedStaticConIx ix -> ResolvedUnliftedStaticConRef ix
    164 205
    165 206 
         | Just (_, rhv) <- lookupNameBytecodeState bco_loader_state nm
    166 207 
         -> return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv))

  • compiler/GHC/ByteCode/Serialize.hs
    ... ... @@ -315,22 +315,39 @@ instance Binary CompiledByteCode where
    315 315 
         put_ bh bc_spt_entries
    316 316
    317 317 
     instance Binary UnlinkedBCO where
    318 
    -  get bh =
    319 
    -    UnlinkedBCO
    320 
    -      <$> getViaBinName bh
    321 
    -      <*> get bh
    322 
    -      <*> (Binary.decode <$> get bh)
    323 
    -      <*> (Binary.decode <$> get bh)
    324 
    -      <*> get bh
    325 
    -      <*> get bh
    318 
    +  get bh = do
    319 
    +    t <- getByte bh
    320 
    +    case t of
    321 
    +      0 -> UnlinkedBCO
    322 
    +        <$> getViaBinName bh
    323 
    +        <*> get bh
    324 
    +        <*> (Binary.decode <$> get bh)
    325 
    +        <*> (Binary.decode <$> get bh)
    326 
    +        <*> get bh
    327 
    +        <*> get bh
    328 
    +      1 -> UnlinkedStaticCon
    329 
    +        <$> getViaBinName bh
    330 
    +        <*> getViaBinName bh
    331 
    +        <*> get bh
    332 
    +        <*> get bh
    333 
    +        <*> get bh
    334 
    +      _ -> panic "Binary UnlinkedBCO: invalid byte"
    326 335
    327 336 
       put_ bh UnlinkedBCO {..} = do
    337 
    +    putByte bh 0
    328 338 
         putViaBinName bh unlinkedBCOName
    329 339 
         put_ bh unlinkedBCOArity
    330 340 
         put_ bh $ Binary.encode unlinkedBCOInstrs
    331 341 
         put_ bh $ Binary.encode unlinkedBCOBitmap
    332 342 
         put_ bh unlinkedBCOLits
    333 343 
         put_ bh unlinkedBCOPtrs
    344 
    +  put_ bh UnlinkedStaticCon {..} = do
    345 
    +    putByte bh 1
    346 
    +    putViaBinName bh unlinkedStaticConName
    347 
    +    putViaBinName bh unlinkedStaticConDataConName
    348 
    +    put_ bh unlinkedStaticConLits
    349 
    +    put_ bh unlinkedStaticConPtrs
    350 
    +    put_ bh unlinkedStaticConIsUnlifted
    334 351
    335 352 
     instance Binary BCOPtr where
    336 353 
       get bh = do

  • compiler/GHC/ByteCode/Types.hs
    ... ... @@ -29,6 +29,7 @@ module GHC.ByteCode.Types
    29 29 
       ) where
    30 30
    31 31 
     import GHC.Prelude
    32 
    +import qualified Data.ByteString.Char8 as BS8
    32 33
    33 34 
     import GHC.Data.FastString
    34 35 
     import GHC.Data.FlatBag
    ... ... @@ -248,16 +249,31 @@ data UnlinkedBCO
    248 249 
        = UnlinkedBCO {
    249 250 
             unlinkedBCOName   :: !Name,
    250 251 
             unlinkedBCOArity  :: {-# UNPACK #-} !Int,
    251 
    -        unlinkedBCOInstrs :: !(BCOByteArray Word16),      -- insns
    252 
    -        unlinkedBCOBitmap :: !(BCOByteArray Word),      -- bitmap
    253 
    -        unlinkedBCOLits   :: !(FlatBag BCONPtr),       -- non-ptrs
    254 
    -        unlinkedBCOPtrs   :: !(FlatBag BCOPtr)         -- ptrs
    252 
    +        unlinkedBCOInstrs :: !(BCOByteArray Word16),  -- insns
    253 
    +        unlinkedBCOBitmap :: !(BCOByteArray Word),    -- bitmap
    254 
    +        unlinkedBCOLits   :: !(FlatBag BCONPtr),      -- non-ptrs
    255 
    +        unlinkedBCOPtrs   :: !(FlatBag BCOPtr)        -- ptrs
    256 
    +   }
    257 
    +   -- | An unlinked top-level static constructor
    258 
    +   -- See Note [Static constructors in Bytecode]
    259 
    +   | UnlinkedStaticCon {
    260 
    +        unlinkedStaticConName :: !Name,
    261 
    +        -- ^ The name to which this static constructor is bound, not to be
    262 
    +        -- confused with the name of the static constructor itself
    263 
    +        -- ('unlinkedStaticConDataConName')
    264 
    +        unlinkedStaticConDataConName :: !Name,
    265 
    +        unlinkedStaticConLits :: !(FlatBag BCONPtr), -- non-ptrs
    266 
    +        unlinkedStaticConPtrs :: !(FlatBag BCOPtr),  -- ptrs
    267 
    +        unlinkedStaticConIsUnlifted :: !Bool
    255 268 
        }
    256 269
    257 270 
     instance NFData UnlinkedBCO where
    258 271 
       rnf UnlinkedBCO{..} =
    259 272 
         rnf unlinkedBCOLits `seq`
    260 273 
         rnf unlinkedBCOPtrs
    274 
    +  rnf UnlinkedStaticCon{..} =
    275 
    +    rnf unlinkedStaticConLits `seq`
    276 
    +    rnf unlinkedStaticConPtrs
    261 277
    262 278 
     data BCOPtr
    263 279 
       = BCOPtrName   !Name
    ... ... @@ -270,6 +286,12 @@ instance NFData BCOPtr where
    270 286 
       rnf (BCOPtrBCO bco) = rnf bco
    271 287 
       rnf x = x `seq` ()
    272 288
    289 
    +instance Outputable BCOPtr where
    290 
    +  ppr (BCOPtrName nm)        = text "BCOPtrName" <+> ppr nm
    291 
    +  ppr (BCOPtrPrimOp op)      = text "BCOPtrPrimOp" <+> ppr op
    292 
    +  ppr (BCOPtrBCO bco)        = text "BCOPtrBCO" <+> ppr bco
    293 
    +  ppr (BCOPtrBreakArray mod) = text "<break array for" <+> ppr mod <> char '>'
    294 
    +
    273 295 
     data BCONPtr
    274 296 
       = BCONPtrWord  {-# UNPACK #-} !Word
    275 297 
       | BCONPtrLbl   !FastString
    ... ... @@ -287,6 +309,16 @@ data BCONPtr
    287 309 
       -- | A 'CostCentre' remote pointer array's respective 'BreakpointId'
    288 310 
       | BCONPtrCostCentre !InternalBreakpointId
    289 311
    312 
    +instance Outputable BCONPtr where
    313 
    +  ppr (BCONPtrWord w)         = integer (fromIntegral w)
    314 
    +  ppr (BCONPtrLbl lbl)        = text "<label:" <> ftext lbl <> char '>'
    315 
    +  ppr (BCONPtrItbl nm)        = text "<itbl:" <+> ppr nm <> char '>'
    316 
    +  ppr (BCONPtrAddr nm)        = text "<addr:" <+> ppr nm <> char '>'
    317 
    +  ppr (BCONPtrStr bs)         = text "<string literal: " <+> text (BS8.unpack bs) <> char '>'
    318 
    +  ppr (BCONPtrFS fs)          = text "<fast string literal:" <+> ftext fs <> char '>'
    319 
    +  ppr (BCONPtrFFIInfo _)      = text "<FFIInfo>"
    320 
    +  ppr (BCONPtrCostCentre bid) = text "<CostCentre for BreakpointId:" <+> ppr bid <> char '>'
    321 
    +
    290 322 
     instance NFData BCONPtr where
    291 323 
       rnf x = x `seq` ()
    292 324
    ... ... @@ -295,6 +327,12 @@ instance Outputable UnlinkedBCO where
    295 327 
           = sep [text "BCO", ppr nm, text "with",
    296 328 
                  ppr (sizeFlatBag lits), text "lits",
    297 329 
                  ppr (sizeFlatBag ptrs), text "ptrs" ]
    330 
    +   ppr (UnlinkedStaticCon nm dc_nm lits ptrs unl)
    331 
    +      = sep [text "StaticCon", ppr nm, text "for",
    332 
    +             if unl then text "unlifted" else text "lifted",
    333 
    +             ppr dc_nm, text "with",
    334 
    +             ppr (sizeFlatBag lits), text "lits",
    335 
    +             ppr (sizeFlatBag ptrs), text "ptrs" ]
    298 336
    299 337 
     instance Binary FFIInfo where
    300 338 
       get bh = FFIInfo <$> get bh <*> get bh

  • compiler/GHC/Cmm/Liveness.hs
    ... ... @@ -63,7 +63,7 @@ cmmGlobalLiveness platform graph =
    63 63
    64 64 
     -- | On entry to the procedure, there had better not be any LocalReg's live-in.
    65 65 
     -- If you see this error it most likely means you are trying to use a variable
    66 
    --- without it being defined in the given scope.
    66 
    +-- without it being defined, or initialized, in the given scope.
    67 67 
     noLiveOnEntry :: BlockId -> CmmLive LocalReg -> a -> a
    68 68 
     noLiveOnEntry bid in_fact x =
    69 69 
       if nullRegSet in_fact then x

  • compiler/GHC/Linker/Loader.hs
    ... ... @@ -1043,11 +1043,35 @@ linkSomeBCOs interp pkgs_loaded bytecode_state mods = foldr fun do_link mods []
    1043 1043 
       do_link [] = return []
    1044 1044 
       do_link mods = do
    1045 1045 
         let flat = [ bco | bcos <- mods, bco <- bcos ]
    1046 
    -        names = map unlinkedBCOName flat
    1047 
    -        bco_ix = mkNameEnv (zip names [0..])
    1046 
    +        unl_objs = filter isUnliftedObj flat
    1047 
    +        lif_objs = filter (not . isUnliftedObj) flat
    1048 
    +        unl_objs_ix = mkNameEnv (zipWith mkBCOIx [0..] unl_objs)
    1049 
    +        lif_objs_ix = mkNameEnv (zipWith mkBCOIx [0..] lif_objs)
    1050 
    +        bco_ix = plusNameEnv unl_objs_ix lif_objs_ix
    1048 1051 
         resolved <- sequence [ linkBCO interp pkgs_loaded bytecode_state bco_ix bco | bco <- flat ]
    1049 
    -    hvrefs <- createBCOs interp resolved
    1050 
    -    return (zip names hvrefs)
    1052 
    +    hvrefs   <- createBCOs interp resolved
    1053 
    +    return (zip (map mkBCOName $ unl_objs ++ lif_objs) hvrefs)
    1054 
    +
    1055 
    +  mkBCOName UnlinkedBCO{unlinkedBCOName}
    1056 
    +    = unlinkedBCOName
    1057 
    +  mkBCOName UnlinkedStaticCon{unlinkedStaticConName}
    1058 
    +    = unlinkedStaticConName
    1059 
    +
    1060 
    +  mkBCOIx ix
    1061 
    +    UnlinkedBCO{unlinkedBCOName}
    1062 
    +    = (unlinkedBCOName, BCOIx ix)
    1063 
    +  mkBCOIx ix
    1064 
    +    UnlinkedStaticCon
    1065 
    +      { unlinkedStaticConName
    1066 
    +      , unlinkedStaticConIsUnlifted }
    1067 
    +    | unlinkedStaticConIsUnlifted
    1068 
    +    = (unlinkedStaticConName, UnliftedStaticConIx ix)
    1069 
    +    | otherwise
    1070 
    +    = (unlinkedStaticConName, LiftedStaticConIx ix)
    1071 
    +
    1072 
    +  isUnliftedObj = \case
    1073 
    +      UnlinkedStaticCon{..} -> unlinkedStaticConIsUnlifted
    1074 
    +      _                     -> False
    1051 1075
    1052 1076 
     -- | Useful to apply to the result of 'linkSomeBCOs'
    1053 1077 
     makeForeignNamedHValueRefs

  • compiler/GHC/StgToByteCode.hs
    ... ... @@ -301,6 +301,21 @@ argBits platform (rep : args)
    301 301 
     -- Compile code for the right-hand side of a top-level binding
    302 302
    303 303 
     schemeTopBind :: (Id, CgStgRhs) -> BcM ProtoBCO
    304 
    +schemeTopBind (id, rhs@(StgRhsCon _ dc _ _ args _))
    305 
    +  = do
    306 
    +    profile <- getProfile
    307 
    +    let non_voids = addArgReps (assertNonVoidStgArgs args)
    308 
    +        (_, _, args_offsets)
    309 
    +                  -- Compute the expected runtime ordering for the datacon fields
    310 
    +                  = mkVirtConstrOffsets profile non_voids
    311 
    +    return ProtoStaticCon
    312 
    +      { protoStaticConName = getName id
    313 
    +      , protoStaticCon     = dc
    314 
    +      , protoStaticConData = [ case a of StgLitArg l -> Left l
    315 
    +                                         StgVarArg i -> Right i
    316 
    +                             | (NonVoid a, _) <- args_offsets ]
    317 
    +      , protoStaticConExpr = rhs
    318 
    +      }
    304 319 
     schemeTopBind (id, rhs)
    305 320 
       | Just data_con <- isDataConWorkId_maybe id,
    306 321 
         isNullaryRepDataCon data_con = do
    ... ... @@ -321,7 +336,6 @@ schemeTopBind (id, rhs)
    321 336 
       | otherwise
    322 337 
       = schemeR [{- No free variables -}] (getName id, rhs)
    323 338
    324 
    -
    325 339 
     -- -----------------------------------------------------------------------------
    326 340 
     -- schemeR
    327 341
    ... ... @@ -341,22 +355,22 @@ schemeR :: [Id] -- Free vars of the RHS, ordered as they
    341 355 
                                     -- top-level things, which have no free vars.
    342 356 
             -> (Name, CgStgRhs)
    343 357 
             -> BcM ProtoBCO
    344 
    -schemeR fvs (nm, rhs)
    345 
    -   = schemeR_wrk fvs nm rhs (collect rhs)
    358 
    +schemeR fvs (nm, rhs@(StgRhsClosure _ _ _ args body _))
    359 
    +   = schemeR_wrk fvs nm rhs (args, body)
    360 
    +schemeR fvs (nm, rhs@(StgRhsCon _cc dc cnum _ticks args _type))
    361 
    +   -- unlike top-level StgRhsCon, which are static (see schemeTopBind),
    362 
    +   -- non-top-level StgRhsCon are compiled just like StgRhsClosure StgConApp
    363 
    +   = schemeR_wrk fvs nm rhs ([], StgConApp dc cnum args [])
    346 364
    347 365 
     -- If an expression is a lambda, return the
    348 366 
     -- list of arguments to the lambda (in R-to-L order) and the
    349 367 
     -- underlying expression
    350 368
    351 
    -collect :: CgStgRhs -> ([Var], CgStgExpr)
    352 
    -collect (StgRhsClosure _ _ _ args body _) = (args, body)
    353 
    -collect (StgRhsCon _cc dc cnum _ticks args _typ) = ([], StgConApp dc cnum args [])
    354 
    -
    355 369 
     schemeR_wrk
    356 370 
         :: [Id]
    357 371 
         -> Name
    358 372 
         -> CgStgRhs            -- expression e, for debugging only
    359 
    -    -> ([Var], CgStgExpr)  -- result of collect on e
    373 
    +    -> ([Var], CgStgExpr)  -- the args and body of an StgRhsClosure
    360 374 
         -> BcM ProtoBCO
    361 375 
     schemeR_wrk fvs nm original_body (args, body)
    362 376 
        = do
    ... ... @@ -546,7 +560,9 @@ schemeE d s p (StgLet _ext binds body) = do
    546 560 
              sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss
    547 561
    548 562 
              -- the arity of each rhs
    549 
    -         arities = map (strictGenericLength . fst . collect) rhss
    563 
    +         stgRhsArity (StgRhsClosure _ _ _ args _ _) = strictGenericLength args
    564 
    +         stgRhsArity StgRhsCon{}                    = 0
    565 
    +         arities = map stgRhsArity rhss
    550 566
    551 567 
              -- This p', d' defn is safe because all the items being pushed
    552 568 
              -- are ptrs, so all have size 1 word.  d' and p' reflect the stack
    ... ... @@ -622,7 +638,7 @@ schemeE d s p (StgCase scrut bndr _ alts)
    622 638 
       and then compile the code as if it was just the expression E.
    623 639 
     -}
    624 640
    625 
    --- Compile code to do a tail call.  Specifically, push the fn,
    641 
    +-- | Compile code to do a tail call.  Specifically, push the fn,
    626 642 
     -- slide the on-stack app back down to the sequel depth,
    627 643 
     -- and enter.  Four cases:
    628 644 
     --
    ... ... @@ -642,7 +658,6 @@ schemeE d s p (StgCase scrut bndr _ alts)
    642 658 
     --
    643 659 
     -- 4.  Otherwise, it must be a function call.  Push the args
    644 660 
     --     right to left, SLIDE and ENTER.
    645 
    -
    646 661 
     schemeT :: StackDepth   -- Stack depth
    647 662 
             -> Sequel       -- Sequel depth
    648 663 
             -> BCEnv        -- stack env

  • compiler/GHC/StgToCmm/Closure.hs
    ... ... @@ -339,7 +339,7 @@ type DynTag = Int -- The tag on a *pointer*
    339 339 
     -- Also see Note [Tagging big families] in GHC.StgToCmm.Expr
    340 340 
     --
    341 341 
     -- The interpreter also needs to be updated if we change the
    342 
    --- tagging strategy; see tagConstr in rts/Interpreter.c.
    342 
    +-- tagging strategy; see tagConstr in rts/storage/ClosureMacros.h.
    343 343
    344 344 
     isSmallFamily :: Platform -> Int -> Bool
    345 345 
     isSmallFamily platform fam_size = fam_size <= mAX_PTR_TAG platform

  • compiler/GHC/StgToCmm/Prim.hs
    ... ... @@ -1771,6 +1771,7 @@ emitPrimOp cfg primop =
    1771 1771 
       DataToTagLargeOp -> alwaysExternal
    1772 1772 
       MkApUpd0_Op -> alwaysExternal
    1773 1773 
       NewBCOOp -> alwaysExternal
    1774 
    +  NewConAppObjOp -> alwaysExternal
    1774 1775 
       UnpackClosureOp -> alwaysExternal
    1775 1776 
       ListThreadsOp -> alwaysExternal
    1776 1777 
       ClosureSizeOp -> alwaysExternal

  • compiler/GHC/StgToJS/Prim.hs
    ... ... @@ -1165,6 +1165,7 @@ genPrim prof bound ty op = case op of
    1165 1165 
       AnyToAddrOp                       -> unhandledPrimop op
    1166 1166 
       MkApUpd0_Op                       -> unhandledPrimop op
    1167 1167 
       NewBCOOp                          -> unhandledPrimop op
    1168 
    +  NewConAppObjOp                    -> unhandledPrimop op
    1168 1169 
       UnpackClosureOp                   -> unhandledPrimop op
    1169 1170 
       ClosureSizeOp                     -> unhandledPrimop op
    1170 1171 
       GetApStackValOp                   -> unhandledPrimop op

  • libraries/ghci/GHCi/CreateBCO.hs
    1 1 
     {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
    2 2 
     {-# LANGUAGE MultiParamTypeClasses #-}
    3 
    +{-# LANGUAGE StandaloneKindSignatures #-}
    4 
    +{-# LANGUAGE UnliftedNewtypes #-}
    5 
    +{-# LANGUAGE TypeApplications #-}
    3 6 
     {-# LANGUAGE FlexibleInstances #-}
    4 7 
     {-# LANGUAGE BangPatterns #-}
    5 8 
     {-# LANGUAGE MagicHash #-}
    6 9 
     {-# LANGUAGE UnboxedTuples #-}
    7 10 
     {-# LANGUAGE RecordWildCards #-}
    8 11 
     {-# LANGUAGE CPP #-}
    12 
    +{-# LANGUAGE LambdaCase #-}
    13 
    +{-# LANGUAGE KindSignatures #-}
    9 14
    10 15 
     --
    11 16 
     --  (c) The University of Glasgow 2002-2006
    ... ... @@ -15,103 +20,321 @@
    15 20 
     module GHCi.CreateBCO (createBCOs) where
    16 21
    17 22 
     import Prelude -- See note [Why do we import Prelude here?]
    23 
    +import Data.List (sortBy)
    24 
    +import Data.Ord (comparing)
    18 25 
     import GHCi.ResolvedBCO
    19 26 
     import GHCi.RemoteTypes
    20 27 
     import GHCi.BreakArray
    21 28 
     import GHC.Data.SizedSeq
    29 
    +import Data.List (partition)
    30 
    +import Data.Graph
    22 31
    23 32 
     import System.IO (fixIO)
    24 33 
     import Control.Monad
    25 34 
     import Data.Array.Base
    26 35 
     import Foreign hiding (newArray)
    27 
    -import Unsafe.Coerce (unsafeCoerce)
    36 
    +import Unsafe.Coerce (unsafeCoerce, unsafeCoerceUnlifted)
    28 37 
     import GHC.Arr          ( Array(..) )
    29 38 
     import GHC.Exts   hiding ( BCO, mkApUpd0#, newBCO# )
    30 39 
     import GHC.Internal.Base ( BCO, mkApUpd0#, newBCO# )
    31 40 
     import GHC.IO
    32 41 
     import Control.Exception ( ErrorCall(..) )
    33 42
    43 
    +{-
    44 
    +Note [Tying the knot in createBCOs]
    45 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    46 
    +There are two passes for creating the BCOs:
    47 
    +
    48 
    +1. Allocate unlifted static cons, which are never mutual recursive, but may refer
    49 
    +   to the array constructed in the second pass.
    50 
    +
    51 
    +2. Allocate BCOs and lifted static cons, which may have circular references
    52 
    +   amongst themselves, and also refer to the unlifted cons allocated in the
    53 
    +   first pass.
    54 
    +
    55 
    +Notably, it is crucial that all unlifted static cons are eagerly allocated,
    56 
    +returning an evaluated and properly tagged unlifted value, and that all
    57 
    +references to an unlifted static constructor use that unlifted value directly,
    58 
    +rather than a thunk, to preserve the unliftedness invariants. Not doing so
    59 
    +resulted in #25636, which was fixed by the commit introducing this Note.
    60 
    +
    61 
    +The unlifted static cons must be allocated in topological order, to ensure a
    62 
    +reference from one to another has already been allocated and can be promptly used.
    63 
    +
    64 
    +The BCOs and lifted cons are allocated in 'fixIO', where references to other
    65 
    +BCOs and static cons in the same group are resolved by writing into the
    66 
    +'PtrsArr' a thunk that indexes the recursively constructed array of BCOs.
    67 
    +References to unlifted cons are looked up in the array from the first pass and
    68 
    +must definitely not be thunks.
    69 
    +
    70 
    +References from unlifted cons to BCOs are resolved similarly by constructing a
    71 
    +thunk into the second pass array, hence why allocating the unlifted cons must
    72 
    +be inside of the 'fixIO'.
    73 
    +-}
    74 
    +
    34 75 
     createBCOs :: [ResolvedBCO] -> IO [HValueRef]
    35 
    -createBCOs bcos = do
    76 
    +createBCOs objs = do
    77 
    +
    78 
    +  let (unl_objs, bcos) = partition isUnliftedObj objs
    79 
    +
    36 80 
       let n_bcos = length bcos
    37 
    -  hvals <- fixIO $ \hvs -> do
    38 
    -     let arr = listArray (0, n_bcos-1) hvs
    39 
    -     mapM (createBCO arr) bcos
    40 
    -  mapM mkRemoteRef hvals
    81 
    +  -- See Note [Tying the knot in createBCOs]
    82 
    +  (unl_hvals, hvals) <- fixIO $ \ ~(_, hvs) -> do
    83 
    +
    84 
    +    let arr = listArray (0, n_bcos-1) hvs
    41 85
    42 
    -createBCO :: Array Int HValue -> ResolvedBCO -> IO HValue
    43 
    -createBCO _   ResolvedBCO{..} | resolvedBCOIsLE /= isLittleEndian
    86 
    +    -- First, construct the array of unlifted static cons.
    87 
    +    --
    88 
    +    -- Top-level unlifted constructors are never mutual recursive, so we can do
    89 
    +    -- this by filling the array in topological order.
    90 
    +    --
    91 
    +    -- Lifted fields of unlifted data will store
    92 
    +    -- thunks indexing the `arr` constructed by fixIO.
    93 
    +    (unl_cons, unl_hvals) <- createUnliftedStaticCons unl_objs arr
    94 
    +
    95 
    +    -- Second, construct the lifted BCOs and static cons which may have
    96 
    +    -- (circular) references to one another in this group. References from this
    97 
    +    -- group to the unlifted static cons will be resolved by looking them up in
    98 
    +    -- the array constructed in the first pass.
    99 
    +    hvals <- mapM (createBCO arr unl_cons) bcos
    100 
    +    return (unl_hvals, hvals)
    101 
    +
    102 
    +  mapM mkRemoteRef (unl_hvals ++ hvals)
    103 
    +
    104 
    +  where
    105 
    +    isUnliftedObj :: ResolvedBCO -> Bool
    106 
    +    isUnliftedObj = \case
    107 
    +      ResolvedStaticCon{..} -> resolvedStaticConIsUnlifted
    108 
    +      _                     -> False
    109 
    +
    110 
    +createBCO :: Array Int HValue -> UnlConsArr -> ResolvedBCO -> IO HValue
    111 
    +createBCO _ _ obj | resolvedBCOIsLE obj /= isLittleEndian
    44 112 
       = throwIO (ErrorCall $
    45 113 
             unlines [ "The endianness of the ResolvedBCO does not match"
    46 114 
                     , "the systems endianness. Using ghc and iserv in a"
    47 115 
                     , "mixed endianness setup is not supported!"
    48 116 
                     ])
    49 
    -createBCO arr bco
    50 
    -   = do linked_bco <- linkBCO' arr bco
    51 
    -        -- Note [Updatable CAF BCOs]
    52 
    -        -- ~~~~~~~~~~~~~~~~~~~~~~~~~
    53 
    -        -- Why do we need mkApUpd0 here?  Otherwise top-level
    54 
    -        -- interpreted CAFs don't get updated after evaluation.  A
    55 
    -        -- top-level BCO will evaluate itself and return its value
    56 
    -        -- when entered, but it won't update itself.  Wrapping the BCO
    57 
    -        -- in an AP_UPD thunk will take care of the update for us.
    58 
    -        --
    59 
    -        -- Furthermore:
    60 
    -        --   (a) An AP thunk *must* point directly to a BCO
    61 
    -        --   (b) A zero-arity BCO *must* be wrapped in an AP thunk
    62 
    -        --   (c) An AP is always fully saturated, so we *can't* wrap
    63 
    -        --       non-zero arity BCOs in an AP thunk.
    64 
    -        --
    65 
    -        -- See #17424.
    66 
    -        if (resolvedBCOArity bco > 0)
    67 
    -           then return (HValue (unsafeCoerce linked_bco))
    68 
    -           else case mkApUpd0# linked_bco of { (# final_bco #) ->
    69 
    -                  return (HValue final_bco) }
    70 
    -
    71 
    -
    72 
    -linkBCO' :: Array Int HValue -> ResolvedBCO -> IO BCO
    73 
    -linkBCO' arr ResolvedBCO{..} = do
    74 
    -  let
    75 
    -      ptrs   = ssElts resolvedBCOPtrs
    76 
    -      n_ptrs = sizeSS resolvedBCOPtrs
    117 
    +createBCO arr unl_arr bco
    118 
    +   = do linked_thing <- linkBCO' arr unl_arr bco
    119 
    +        case linked_thing of
    120 
    +          LinkedBCO bco_arity linked_bco -> do
    121 
    +            -- Note [Updatable CAF BCOs]
    122 
    +            -- ~~~~~~~~~~~~~~~~~~~~~~~~~
    123 
    +            -- Why do we need mkApUpd0 here?  Otherwise top-level
    124 
    +            -- interpreted CAFs don't get updated after evaluation.  A
    125 
    +            -- top-level BCO will evaluate itself and return its value
    126 
    +            -- when entered, but it won't update itself.  Wrapping the BCO
    127 
    +            -- in an AP_UPD thunk will take care of the update for us.
    128 
    +            --
    129 
    +            -- Furthermore:
    130 
    +            --   (a) An AP thunk *must* point directly to a BCO
    131 
    +            --   (b) A zero-arity BCO *must* be wrapped in an AP thunk
    132 
    +            --   (c) An AP is always fully saturated, so we *can't* wrap
    133 
    +            --       non-zero arity BCOs in an AP thunk.
    134 
    +            --
    135 
    +            -- See #17424.
    136 
    +            if (bco_arity > 0)
    137 
    +               then return (HValue (unsafeCoerce linked_bco))
    138 
    +               else case mkApUpd0# linked_bco of { (# final_bco #) ->
    139 
    +                      return (HValue final_bco) }
    140 
    +          LinkedStaticCon linked_static_con -> do
    141 
    +            return linked_static_con
    142 
    +          LinkedUnliftedStaticCon linked_static_con -> do
    143 
    +            return $! forgetUnliftedHValue linked_static_con
    144 
    +
    145 
    +-- | The resulting of linking a BCO or static constructor
    146 
    +data LinkedBCO
    147 
    +  = LinkedBCO !Int{-BCO arity-} BCO
    148 
    +  | LinkedStaticCon HValue
    149 
    +  | LinkedUnliftedStaticCon UnliftedHValue
    150 
    +
    151 
    +-- | Construct an array of unlifted constructor closures given a list of 'UnliftedStaticCons'.
    152 
    +--
    153 
    +-- INVARIANT: Top-level unlifted constructors are never mutual recursive, so we
    154 
    +-- can do this by filling the array in topological order.
    155 
    +--
    156 
    +-- Lifted fields of unlifted data will be filled by looking them up in the
    157 
    +-- given array of lifted resolved objs.
    158 
    +createUnliftedStaticCons
    159 
    +  :: [ResolvedBCO]    -- ^ 'UnliftedStaticCon's ONLY.
    160 
    +  -> Array Int HValue -- ^ Lifted resolved objects
    161 
    +  -> IO (UnlConsArr, [HValue])
    162 
    +  -- ^ Return both the array to look up the unlifted static constrs by 'BCOIx',
    163 
    +  -- and a list with the same unlifted objects, albeit the unliftedness is
    164 
    +  -- forgotten using 'forgetUnliftedHValue' (allowing them to be put into a
    165 
    +  -- list and later combined with the heap values of lifted objects).
    166 
    +createUnliftedStaticCons objs lif_arr = do
    167 
    +
    168 
    +  -- Get topologically sorted objs with their original indices
    169 
    +  let topoSortedObjs = topSortObjs objs
    170 
    +  unl_arr <- newUnlConsArr (length topoSortedObjs)
    77 171
    78 
    -      !(I# arity#)  = resolvedBCOArity
    172 
    +  -- Process objs in topological order, but write them at their original indexes
    173 
    +  indexed_vs <- forM topoSortedObjs $ \(origIdx, obj) -> case obj of
    174 
    +    ResolvedStaticCon{..}
    175 
    +      | resolvedStaticConIsUnlifted
    176 
    +      -> do
    177 
    +        -- Because we topologically sort the objs, all unlifted references we
    178 
    +        -- care about when linking this BCO will already be filled in.
    179 
    +        -- The lifted ones are resolved by knot tying (see the fixIO above).
    180 
    +        lbc <- linkBCO' lif_arr unl_arr obj
    181 
    +        case lbc of
    182 
    +          LinkedUnliftedStaticCon linked_static_con -> do
    183 
    +            writeUnlConsArr origIdx linked_static_con unl_arr -- Write it to its original index position
    184 
    +            return (origIdx, forgetUnliftedHValue linked_static_con)
    185 
    +          _ -> error "createUnliftedStaticCons: unexpected lifted ResolvedBCO"
    186 
    +    _ ->
    187 
    +      error "createUnliftedStaticCons: unexpected lifted ResolvedBCO"
    79 188
    80 
    -      !(EmptyArr empty#) = emptyArr -- See Note [BCO empty array]
    81 
    -      barr arr# = if I# (sizeofByteArray# arr#) == 0 then empty# else arr#
    82 
    -      insns_barr = barr (getBCOByteArray resolvedBCOInstrs)
    83 
    -      bitmap_barr = barr (getBCOByteArray resolvedBCOBitmap)
    84 
    -      literals_barr = barr (getBCOByteArray resolvedBCOLits)
    189 
    +  -- Return them in the original order
    190 
    +  let vs = map snd $ sortBy (comparing fst) indexed_vs
    191 
    +  return (unl_arr, vs)
    192 
    +  where
    193 
    +    -- Return the topologically sorted objects with their original index.
    194 
    +    topSortObjs :: [ResolvedBCO] -> [(Int, ResolvedBCO)]
    195 
    +    topSortObjs objs =
    196 
    +      let
    197 
    +        edges = [ ((origIdx, obj), origIdx, getUnlDeps obj)
    198 
    +                | (origIdx, obj) <- zip [0..] objs ]
    85 199
    86 
    -  PtrsArr marr <- mkPtrsArray arr n_ptrs ptrs
    87 
    -  IO $ \s ->
    88 
    -    case unsafeFreezeArray# marr s of { (# s, arr #) ->
    89 
    -    case newBCO insns_barr literals_barr arr arity# bitmap_barr of { IO io ->
    90 
    -    io s
    91 
    -    }}
    200 
    +        getUnlDeps :: ResolvedBCO -> [Int]
    201 
    +        getUnlDeps (ResolvedStaticCon{..}) =
    202 
    +          [ k | ptr <- ssElts resolvedStaticConPtrs
    203 
    +              , ResolvedUnliftedStaticConRef k <- [ptr] ]
    204 
    +        getUnlDeps _ = []
    92 205
    206 
    +        (graph, vertexToNode, _keyToVertex) = graphFromEdges edges
    207 
    +        sortedVertices = topSort graph
    208 
    +      in
    209 
    +        [ ix_obj | v <- sortedVertices
    210 
    +                 , let (ix_obj, _, _) = vertexToNode v ]
    211 
    +
    212 
    +linkBCO' :: Array Int HValue -> UnlConsArr -> ResolvedBCO -> IO LinkedBCO
    213 
    +linkBCO' arr unl_arr resolved_obj =
    214 
    +  case resolved_obj of
    215 
    +    ResolvedBCO{..} -> do
    216 
    +      let
    217 
    +          ptrs   = ssElts resolvedBCOPtrs
    218 
    +          n_ptrs = sizeSS resolvedBCOPtrs
    219 
    +
    220 
    +          !(I# arity#)  = resolvedBCOArity
    221 
    +
    222 
    +          insns_barr = barr (getBCOByteArray resolvedBCOInstrs)
    223 
    +          bitmap_barr = barr (getBCOByteArray resolvedBCOBitmap)
    224 
    +          literals_barr = barr (getBCOByteArray resolvedBCOLits)
    225 
    +
    226 
    +      PtrsArr marr <- mkPtrsArray arr unl_arr n_ptrs ptrs
    227 
    +      IO $ \s ->
    228 
    +        case unsafeFreezeArray# marr s of { (# s, arr #) ->
    229 
    +        case newBCO# insns_barr literals_barr arr arity# bitmap_barr s of
    230 
    +          (# s, hval #) -> (# s, LinkedBCO resolvedBCOArity hval #)
    231 
    +        }
    232 
    +    ResolvedStaticCon{..} -> do
    233 
    +
    234 
    +      let
    235 
    +        ptrs             = ssElts resolvedStaticConPtrs
    236 
    +        n_ptrs           = sizeSS resolvedStaticConPtrs
    237 
    +        !(W# data_size#) = resolvedStaticConArity
    238 
    +
    239 
    +        literals_barr = barr (getBCOByteArray resolvedStaticConLits)
    240 
    +
    241 
    +        !(W# itbl_ptr_w#) = resolvedStaticConInfoPtr
    242 
    +        !(Ptr itbl_ptr#)  = Ptr (int2Addr# (word2Int# itbl_ptr_w#))
    243 
    +
    244 
    +      PtrsArr marr <- mkPtrsArray arr unl_arr n_ptrs ptrs
    245 
    +
    246 
    +      IO $ \s ->
    247 
    +        case unsafeFreezeArray# marr s of { (# s, arr #) ->
    248 
    +        case newConAppObj# itbl_ptr# literals_barr arr data_size# s of
    249 
    +          (# s, hval #) ->
    250 
    +            if resolvedStaticConIsUnlifted then
    251 
    +              (# s, LinkedUnliftedStaticCon (UnliftedHValue (unsafeCoerce# hval)) #)
    252 
    +            else
    253 
    +              (# s, LinkedStaticCon (HValue hval) #)
    254 
    +        }
    255 
    +  where
    256 
    +    !(EmptyArr empty#) = emptyArr -- See Note [BCO empty array]
    257 
    +    barr arr# = if I# (sizeofByteArray# arr#) == 0 then empty# else arr#
    93 258
    94 259 
     -- we recursively link any sub-BCOs while making the ptrs array
    95 
    -mkPtrsArray :: Array Int HValue -> Word -> [ResolvedBCOPtr] -> IO PtrsArr
    96 
    -mkPtrsArray arr n_ptrs ptrs = do
    260 
    +mkPtrsArray :: Array Int HValue -> UnlConsArr -> Word -> [ResolvedBCOPtr] -> IO PtrsArr
    261 
    +mkPtrsArray arr unl_arr n_ptrs ptrs = do
    97 262 
       marr <- newPtrsArray (fromIntegral n_ptrs)
    98 263 
       let
    99 264 
         fill (ResolvedBCORef n) i =
    100 265 
           writePtrsArrayHValue i (arr ! n) marr  -- must be lazy!
    266 
    +    fill (ResolvedStaticConRef n) i = do
    267 
    +      writePtrsArrayHValue i (arr ! n) marr  -- must be lazy!
    268 
    +    fill (ResolvedUnliftedStaticConRef n) i = do
    269 
    +      -- must be strict! we want to store the unlifted con,
    270 
    +      -- not the arr indexing thunk.
    271 
    +      !unl_val <- readUnlConsArr n unl_arr
    272 
    +      writePtrsArrayHValue i unl_val marr
    101 273 
         fill (ResolvedBCOPtr r) i = do
    102 274 
           hv <- localRef r
    103 275 
           writePtrsArrayHValue i hv marr
    104 276 
         fill (ResolvedBCOStaticPtr r) i = do
    105 277 
           writePtrsArrayPtr i (fromRemotePtr r)  marr
    106 278 
         fill (ResolvedBCOPtrBCO bco) i = do
    107 
    -      bco <- linkBCO' arr bco
    108 
    -      writePtrsArrayBCO i bco marr
    279 
    +      obj <- linkBCO' arr unl_arr bco
    280 
    +      case obj of
    281 
    +        LinkedBCO _ bco ->
    282 
    +          writePtrsArrayBCO i bco marr
    283 
    +        LinkedStaticCon linked_static_con ->
    284 
    +          writePtrsArrayHValue i linked_static_con marr
    285 
    +        LinkedUnliftedStaticCon linked_static_con -> do
    286 
    +          let !unl_val = forgetUnliftedHValue linked_static_con
    287 
    +          writePtrsArrayHValue i unl_val marr
    109 288 
         fill (ResolvedBCOPtrBreakArray r) i = do
    110 289 
           BA mba <- localRef r
    111 290 
           writePtrsArrayMBA i mba marr
    112 291 
       zipWithM_ fill ptrs [0..]
    113 292 
       return marr
    114 293
    294 
    +--------------------------------------------------------------------------------
    295 
    +-- * Unlifted static constructors
    296 
    +--------------------------------------------------------------------------------
    297 
    +
    298 
    +-- | A heap closure of unlifted type
    299 
    +type UnliftedHValue :: UnliftedType
    300 
    +newtype UnliftedHValue = UnliftedHValue (Any @UnliftedType)
    301 
    +
    302 
    +-- | Forget that a heap closure is unlifted, and return it as a lifted heap closure.
    303 
    +-- Note: Going the other way around for an arbitrary heap closure is totally unsafe!
    304 
    +forgetUnliftedHValue :: UnliftedHValue -> HValue
    305 
    +forgetUnliftedHValue (UnliftedHValue a) = HValue (unsafeCoerce# a)
    306 
    +
    307 
    +-- | A lifted array with unlifted static constructor 'UnliftedHValue's
    308 
    +data UnlConsArr = UnlConsArr (MutableArray# RealWorld UnliftedHValue)
    309 
    +
    310 
    +-- | Create a 'UnlConsArr' of the given size with all elements initialized to
    311 
    +-- an empty ByteArray#
    312 
    +newUnlConsArr :: Int -> IO UnlConsArr
    313 
    +newUnlConsArr (I# arr_size#) = IO $ \s ->
    314 
    +  -- Zero value to initialize the array.
    315 
    +  -- Would be better to use undefined but can't for unlifted values.
    316 
    +  let !(EmptyArr emp_arr#) = emptyArr
    317 
    +  in case newArray# arr_size# (UnliftedHValue (unsafeCoerceUnlifted emp_arr#)) s of
    318 
    +      (# s, arr #) -> (# s, UnlConsArr arr #)
    319 
    +
    320 
    +-- | Write an unlifted contructor closure into a 'UnlConsArr'
    321 
    +writeUnlConsArr :: Int -> UnliftedHValue -> UnlConsArr -> IO ()
    322 
    +writeUnlConsArr (I# i#) unl_hval (UnlConsArr unl_arr#) = IO $ \s ->
    323 
    +  case writeArray# unl_arr# i# unl_hval s of
    324 
    +    s -> (# s, () #)
    325 
    +
    326 
    +-- | Read an unlifted constructor closure from an 'UnlConsArr',
    327 
    +-- but forget that the heap closure is unlifted using 'forgetUnliftedHValue'.
    328 
    +-- This allows us to return it in @IO@ and return it in the final resolved objs list.
    329 
    +readUnlConsArr :: Int -> UnlConsArr -> IO HValue
    330 
    +readUnlConsArr (I# n#) (UnlConsArr unl_arr#) = IO $ \s ->
    331 
    +  case readArray# unl_arr# n# s of
    332 
    +    (# s, val #) -> (# s, forgetUnliftedHValue val #)
    333 
    +
    334 
    +--------------------------------------------------------------------------------
    335 
    +-- * PtrsArr
    336 
    +--------------------------------------------------------------------------------
    337 
    +
    115 338 
     data PtrsArr = PtrsArr (MutableArray# RealWorld HValue)
    116 339
    117 340 
     newPtrsArray :: Int -> IO PtrsArr
    ... ... @@ -145,10 +368,9 @@ writePtrsArrayMBA :: Int -> MutableByteArray# s -> PtrsArr -> IO ()
    145 368 
     writePtrsArrayMBA (I# i) mba (PtrsArr arr) = IO $ \s ->
    146 369 
       case (unsafeCoerce# writeArray#) arr i mba s of s' -> (# s', () #)
    147 370
    148 
    -newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO
    149 
    -newBCO instrs lits ptrs arity bitmap = IO $ \s ->
    150 
    -  newBCO# instrs lits ptrs arity bitmap s
    151 
    -
    371 
    +--------------------------------------------------------------------------------
    372 
    +-- * Empty array
    373 
    +--------------------------------------------------------------------------------
    152 374 
     {- Note [BCO empty array]
    153 375 
        ~~~~~~~~~~~~~~~~~~~~~~
    154 376 
     Lots of BCOs have empty ptrs or nptrs, but empty arrays are not free:
    ... ... @@ -165,3 +387,5 @@ emptyArr = unsafeDupablePerformIO $ IO $ \s ->
    165 387 
       case unsafeFreezeByteArray# arr s of { (# s, farr #) ->
    166 388 
       (# s, EmptyArr farr #)
    167 389 
       }}
    390 
    +
    391 
    +

  • libraries/ghci/GHCi/ResolvedBCO.hs
    ... ... @@ -47,6 +47,16 @@ data ResolvedBCO
    47 47 
               -- ^ non-ptrs - subword sized entries still take up a full (host) word
    48 48 
             resolvedBCOPtrs   :: (SizedSeq ResolvedBCOPtr)  -- ^ ptrs
    49 49 
        }
    50 
    +   -- | A resolved static constructor
    51 
    +   -- See Note [Static constructors in Bytecode]
    52 
    +   | ResolvedStaticCon {
    53 
    +        resolvedBCOIsLE          :: Bool,
    54 
    +        resolvedStaticConInfoPtr :: {-# UNPACK #-} !Word, -- ^ info ptr Addr# as a Word
    55 
    +        resolvedStaticConArity   :: {-# UNPACK #-} !Word,
    56 
    +        resolvedStaticConLits    :: BCOByteArray Word,
    57 
    +        resolvedStaticConPtrs    :: SizedSeq ResolvedBCOPtr,
    58 
    +        resolvedStaticConIsUnlifted :: Bool
    59 
    +   }
    50 60 
        deriving (Generic, Show)
    51 61
    52 62 
     -- | Wrapper for a 'ByteArray#'.
    ... ... @@ -80,13 +90,27 @@ instance Show (BCOByteArray Word) where
    80 90 
     -- same endianness.
    81 91 
     instance Binary ResolvedBCO where
    82 92 
       put ResolvedBCO{..} = do
    93 
    +    putWord8 0
    83 94 
         put resolvedBCOIsLE
    84 95 
         put resolvedBCOArity
    85 96 
         put resolvedBCOInstrs
    86 97 
         put resolvedBCOBitmap
    87 98 
         put resolvedBCOLits
    88 99 
         put resolvedBCOPtrs
    89 
    -  get = ResolvedBCO <$> get <*> get <*> get <*> get <*> get <*> get
    100 
    +  put ResolvedStaticCon{..} = do
    101 
    +    putWord8 1
    102 
    +    put resolvedBCOIsLE
    103 
    +    put resolvedStaticConInfoPtr
    104 
    +    put resolvedStaticConArity
    105 
    +    put resolvedStaticConLits
    106 
    +    put resolvedStaticConPtrs
    107 
    +    put resolvedStaticConIsUnlifted
    108 
    +  get = do
    109 
    +    t <- getWord8
    110 
    +    case t of
    111 
    +      0 -> ResolvedBCO <$> get <*> get <*> get <*> get <*> get <*> get
    112 
    +      1 -> ResolvedStaticCon <$> get <*> get <*> get <*> get <*> get <*> get
    113 
    +      _ -> error "Binary ResolvedBCO: invalid byte"
    90 114
    91 115 
     -- See Note [BCOByteArray serialization]
    92 116 
     instance (Binary a, Storable a, IArray UArray a) => Binary (BCOByteArray a) where
    ... ... @@ -96,7 +120,8 @@ instance (Binary a, Storable a, IArray UArray a) => Binary (BCOByteArray a) wher
    96 120
    97 121 
     data ResolvedBCOPtr
    98 122 
       = ResolvedBCORef {-# UNPACK #-} !Int
    99 
    -      -- ^ reference to the Nth BCO in the current set
    123 
    +      -- ^ reference to the Nth BCO in the current set of BCOs and
    124 
    +      -- lifted static constructors
    100 125 
       | ResolvedBCOPtr {-# UNPACK #-} !(RemoteRef HValue)
    101 126 
           -- ^ reference to a previously created BCO
    102 127 
       | ResolvedBCOStaticPtr {-# UNPACK #-} !(RemotePtr ())
    ... ... @@ -105,6 +130,12 @@ data ResolvedBCOPtr
    105 130 
           -- ^ a nested BCO
    106 131 
       | ResolvedBCOPtrBreakArray {-# UNPACK #-} !(RemoteRef BreakArray)
    107 132 
           -- ^ Resolves to the MutableArray# inside the BreakArray
    133 
    +  | ResolvedStaticConRef {-# UNPACK #-} !Int
    134 
    +      -- ^ reference to the Nth static constructor in the current set of BCOs
    135 
    +      -- and lifted static constructors
    136 
    +  | ResolvedUnliftedStaticConRef {-# UNPACK #-} !Int
    137 
    +      -- ^ reference to the Nth unlifted static constructor in the current set
    138 
    +      -- of exclusively unlifted static constructors
    108 139 
       deriving (Generic, Show)
    109 140
    110 141 
     instance Binary ResolvedBCOPtr

  • rts/Interpreter.c
    ... ... @@ -709,14 +709,6 @@ slow_spw(void *Sp, StgStack *cur_stack, StgWord offset_words){
    709 709 
       }
    710 710 
     }
    711 711
    712 
    -// Compute the pointer tag for the constructor and tag the pointer;
    713 
    -// see Note [Data constructor dynamic tags] in GHC.StgToCmm.Closure.
    714 
    -//
    715 
    -// Note: we need to update this if we change the tagging strategy.
    716 
    -STATIC_INLINE StgClosure *tagConstr(StgClosure *con) {
    717 
    -    return TAG_CLOSURE(stg_min(TAG_MASK, 1 + GET_TAG(con)), con);
    718 
    -}
    719 
    -
    720 712 
     static StgWord app_ptrs_itbl[] = {
    721 713 
         (W_)&stg_ap_p_info,
    722 714 
         (W_)&stg_ap_pp_info,

  • rts/PrimOps.cmm
    ... ... @@ -2208,6 +2208,44 @@ for:
    2208 2208 
         return (bco);
    2209 2209 
     }
    2210 2210
    2211 
    +// Ptr InfoTable, [Literals] [Ptrs] ==> CONSTR heap closure
    2212 
    +stg_newConAppObjzh ( W_ datacon_info, P_ literals, P_ ptrs , W_ arity )
    2213 
    +{
    2214 
    +    W_ con_obj, bytes;
    2215 
    +
    2216 
    +    bytes = SIZEOF_StgHeader + WDS(arity);
    2217 
    +
    2218 
    +    ALLOC_PRIM (bytes);
    2219 
    +    con_obj = Hp - bytes + WDS(1);
    2220 
    +
    2221 
    +    // No memory barrier necessary as this is a new allocation.
    2222 
    +    SET_HDR(con_obj, datacon_info, CCS_MAIN);
    2223 
    +
    2224 
    +    // Copy the ptrs followed by nonptrs into the constructor payload
    2225 
    +    W_ i, n_ptrs;
    2226 
    +    n_ptrs = StgMutArrPtrs_ptrs(ptrs);
    2227 
    +    i = 0;
    2228 
    +loop1:
    2229 
    +    if (i < n_ptrs) {
    2230 
    +        StgClosure_payload(con_obj,i) = StgMutArrPtrs_payload(ptrs,i);
    2231 
    +        i = i + 1;
    2232 
    +        goto loop1;
    2233 
    +    }
    2234 
    +    i = 0;
    2235 
    +loop2:
    2236 
    +    if (i < BYTE_ARR_WDS(literals)) {
    2237 
    +        W_ offset;
    2238 
    +        offset = n_ptrs + i;
    2239 
    +        StgClosure_payload(con_obj,offset) = StgArrBytes_payload(literals,i);
    2240 
    +        i = i + 1;
    2241 
    +        goto loop2;
    2242 
    +    }
    2243 
    +
    2244 
    +    W_ tagged_con_obj;
    2245 
    +    (tagged_con_obj) = ccall tagConstr(con_obj);
    2246 
    +    return (tagged_con_obj);
    2247 
    +}
    2248 
    +
    2211 2249 
     stg_mkApUpd0zh ( P_ bco )
    2212 2250 
     {
    2213 2251 
         W_ ap;

  • rts/RtsSymbols.c
    ... ... @@ -634,6 +634,7 @@ extern char **environ;
    634 634 
           SymI_HasDataProto(stg_casSmallArrayzh)                                \
    635 635 
           SymI_HasDataProto(stg_copyArray_barrier)                              \
    636 636 
           SymI_HasDataProto(stg_newBCOzh)                                       \
    637 
    +      SymI_HasDataProto(stg_newConAppObjzh)                                 \
    637 638 
           SymI_HasDataProto(stg_newByteArrayzh)                                 \
    638 639 
           SymI_HasDataProto(stg_casIntArrayzh)                                  \
    639 640 
           SymI_HasDataProto(stg_casInt8Arrayzh)                                 \
    ... ... @@ -655,7 +656,7 @@ extern char **environ;
    655 656 
           SymI_HasDataProto(stg_isMutableByteArrayWeaklyPinnedzh)               \
    656 657 
           SymI_HasDataProto(stg_shrinkMutableByteArrayzh)                       \
    657 658 
           SymI_HasDataProto(stg_resizzeMutableByteArrayzh)                      \
    658 
    -      SymI_HasDataProto(stg_shrinkSmallMutableArrayzh)                       \
    659 
    +      SymI_HasDataProto(stg_shrinkSmallMutableArrayzh)                      \
    659 660 
           SymI_HasProto(newSpark)                                           \
    660 661 
           SymI_HasProto(updateRemembSetPushThunk)                             \
    661 662 
           SymI_HasProto(updateRemembSetPushThunk_)                            \

  • rts/include/rts/storage/ClosureMacros.h
    ... ... @@ -140,6 +140,16 @@ EXTERN_INLINE StgHalfWord GET_TAG(const StgClosure *con)
    140 140 
         return get_itbl(con)->srt;
    141 141 
     }
    142 142
    143 
    +// Compute the pointer tag for the constructor and tag the pointer;
    144 
    +// see Note [Data constructor dynamic tags] in GHC.StgToCmm.Closure.
    145 
    +//
    146 
    +// Note: we need to update this if we change the tagging strategy.
    147 
    +EXTERN_INLINE StgClosure *tagConstr(StgClosure *con);
    148 
    +EXTERN_INLINE StgClosure *tagConstr(StgClosure *con)
    149 
    +{
    150 
    +    return TAG_CLOSURE(stg_min(TAG_MASK, 1 + GET_TAG(con)), con);
    151 
    +}
    152 
    +
    143 153 
     /* -----------------------------------------------------------------------------
    144 154 
        Macros for building closures
    145 155 
        -------------------------------------------------------------------------- */

  • rts/include/stg/MiscClosures.h
    ... ... @@ -584,6 +584,7 @@ RTS_FUN_DECL(stg_runRWzh);
    584 584
    585 585 
     RTS_FUN_DECL(stg_newBCOzh);
    586 586 
     RTS_FUN_DECL(stg_mkApUpd0zh);
    587 
    +RTS_FUN_DECL(stg_newConAppObjzh);
    587 588
    588 589 
     RTS_FUN_DECL(stg_retryzh);
    589 590 
     RTS_FUN_DECL(stg_catchRetryzh);

  • testsuite/tests/codeGen/should_run/T23146/T25636.stdout
    1 
    +True

  • utils/deriveConstants/Main.hs
    ... ... @@ -460,9 +460,10 @@ wanteds os = concat
    460 460 
               ,closureSize  Both "StgAnnFrame"
    461 461 
               ,closureField C    "StgAnnFrame" "ann"
    462 462
    463 
    -          ,closureSize  Both "StgMutArrPtrs"
    464 
    -          ,closureField Both "StgMutArrPtrs" "ptrs"
    465 
    -          ,closureField Both "StgMutArrPtrs" "size"
    463 
    +          ,closureSize    Both "StgMutArrPtrs"
    464 
    +          ,closureField   Both "StgMutArrPtrs" "ptrs"
    465 
    +          ,closureField   Both "StgMutArrPtrs" "size"
    466 
    +          ,closurePayload C    "StgMutArrPtrs" "payload"
    466 467
    467 468 
               ,closureSize  Both "StgSmallMutArrPtrs"
    468 469 
               ,closureField Both "StgSmallMutArrPtrs" "ptrs"

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help