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

Commits:

7 changed files:

Changes:

  • compiler/GHC/ByteCode/Asm.hs
    ... ... @@ -38,7 +38,7 @@ import GHC.Types.SptEntry
    38 38 
     import GHC.Types.Unique.FM
    39 39 
     import GHC.Unit.Types
    40 40
    41 
    -import GHC.Utils.Outputable ( Outputable(..), text, (<+>), vcat )
    41 
    +import GHC.Utils.Outputable ( Outputable(..), text, (<+>), vcat, ($$) )
    42 42 
     import GHC.Utils.Panic
    43 43
    44 44 
     import GHC.Builtin.Types.Prim ( addrPrimTy )
    ... ... @@ -77,6 +77,8 @@ import GHC.Exts
    77 77 
     import GHC.Core.DataCon
    78 78 
     import GHC.Data.FlatBag
    79 79 
     import GHC.Types.Id
    80 
    +import Data.List (unfoldr)
    81 
    +import GHC.Types.RepType (typePrimRepU)
    80 82
    81 83
    82 84 
     -- -----------------------------------------------------------------------------
    ... ... @@ -214,9 +216,11 @@ assembleBCO platform
    214 216 
                 (ProtoStaticCon { protoStaticConName
    215 217 
                                 , protoStaticCon = dc
    216 218 
                                 , protoStaticConData = args
    219 
    +                            , protoStaticConNonPtrsSize = non_ptr_words
    217 220 
                                 }) = do
    218 
    -  let ptrs    = foldr mappendFlatBag emptyFlatBag (mapMaybe idBCOArg args)
    219 
    -  let nonptrs = foldr mappendFlatBag emptyFlatBag (mapMaybe litBCOArg args)
    221 
    +  let fullword_args = packSubwordArgs platform args
    222 
    +  let ptrs    = foldr mappendFlatBag emptyFlatBag (mapMaybe idBCOArg fullword_args)
    223 
    +  let nonptrs = foldr mappendFlatBag emptyFlatBag (mapMaybe litBCOArg fullword_args)
    220 224 
       pure UnlinkedStaticCon
    221 225 
         { unlinkedStaticConName = protoStaticConName
    222 226 
         , unlinkedStaticConDataConName = dataConName dc
    ... ... @@ -294,6 +298,50 @@ assembleBCO platform
    294 298
    295 299 
       return ul_bco
    296 300
    301 
    +-- | Pack sub-word literals (which should appear contiguously in the argument
    302 
    +-- list) into full words, and leave full-word-sized arguments alone.
    303 
    +packSubwordArgs :: Platform -> [Either Literal Id] -> [Either Literal Id]
    304 
    +packSubwordArgs platform = map packWord . groupWords
    305 
    +  -- Group arguments into lists of total size=platform word size
    306 
    +  where
    307 
    +    -- Assumes packed sub-words are always ordered from largest to smallest
    308 
    +    packWord :: Either [(Literal, Int{-size in bits-})] Id -> Either Literal Id
    309 
    +    packWord (Right v) = Right v -- already word size
    310 
    +    packWord (Left litsWithSizes) = Left $ mkLitWord platform packedValue
    311 
    +      where
    312 
    +        packedValue = case platformByteOrder platform of
    313 
    +          BigEndian ->
    314 
    +            -- For BE, we shift the accumulator left and OR the new value
    315 
    +            foldl' (\acc (val, sz) -> (acc `unsafeShiftL` sz) .|. val) 0 litsWithSizes
    316 
    +
    317 
    +          LittleEndian ->
    318 
    +            -- For LE, the first element is at shift 0, the next at shift (size of first), etc.
    319 
    +            let offsets = scanl (+) 0 [ sz | (_, sz) <- litsWithSizes ]
    320 
    +            in foldl' (\acc ((val, _), shift) -> acc .|. (val `unsafeShiftL` shift)) 0 (zip litsWithSizes offsets)
    321 
    +
    322 
    +    groupWords :: [Either Literal Id] -> [Either [(Literal, Int{-size in bits-})] Id]
    323 
    +    groupWords = unfoldr step
    324 
    +      where
    325 
    +        step [] = Nothing
    326 
    +        step (Right v:xs) = Just (Right v, xs)
    327 
    +        step (Left l:xs) =
    328 
    +          let (chunk, rest) = takeWord 0 [] (Left l:xs)
    329 
    +          in Just (Left chunk, rest)
    330 
    +
    331 
    +        takeWord _ _ [] = panic "packSubwordArgs: Input does not align to 64-bit boundary"
    332 
    +        takeWord !n acc (Right l:ls)
    333 
    +          -- ptrs are word sized by definition, so the accumulated sub-words must already have formed a full word.
    334 
    +          = assertPpr (n == ws) (text "packSubwordArgs: Word-sized argument found before accumulated sub-words formed a full word")
    335 
    +            (reverse acc, Right l:ls)
    336 
    +        takeWord !n acc (Left l:ls)
    337 
    +          | n + s <  ws = takeWord (n+s) ((l,s*8):acc) ls
    338 
    +          | n + s == ws = (reverse ((l,s*8):acc), ls)
    339 
    +          | otherwise   = panic "packSubwordArgs: Element crosses 64-bit boundary"
    340 
    +          where
    341 
    +            s = primRepSizeB platform (typePrimRepU (literalType l))
    342 
    +
    343 
    +    ws = platformWordSizeInBytes platform
    344 
    +
    297 345 
     -- | Construct a word-array containing an @StgLargeBitmap@.
    298 346 
     mkBitmapArray :: Word -> [StgWord] -> UArray Int Word
    299 347 
     -- Here the return type must be an array of Words, not StgWords,

  • compiler/GHC/ByteCode/Instr.hs
    ... ... @@ -58,8 +58,16 @@ data ProtoBCO
    58 58 
             -- We use this to construct the right info table.
    59 59 
             protoStaticConData :: [Either Literal Id],
    60 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.
    61 
    +        -- in the order they should appear at runtime (see
    62 
    +        -- 'mkVirtHeapOffsetsWithPadding' in 'schemeTopBind').
    63 
    +        --
    64 
    +        -- The non-pointer arguments are meant to be laid contiguously in
    65 
    +        -- memory using the width of each literal individually. The padding is
    66 
    +        -- given as Literals of value 0 with the appropriate width.
    67 
    +        protoStaticConNonPtrsSize :: Int,
    68 
    +        -- ^ How many words needed to store the non-pointer arguments.
    69 
    +        -- Note that this may be smaller than the number of non-pointer
    70 
    +        -- arguments, since subword arguments need to be packed.
    63 71 
             protoStaticConExpr :: CgStgRhs
    64 72 
             -- ^ What the static con came from, for debugging only
    65 73 
        }
    ... ... @@ -333,11 +341,12 @@ data BCInstr
    333 341 
     -- Printing bytecode instructions
    334 342
    335 343 
     instance Outputable ProtoBCO where
    336 
    -   ppr (ProtoStaticCon nm con args origin)
    344 
    +   ppr (ProtoStaticCon nm con args nonPtrsSize origin)
    337 345 
           = text "ProtoStaticCon" <+> ppr nm <> colon
    338 346 
             $$ nest 3 (pprStgRhsShort shortStgPprOpts origin)
    339 347 
             $$ nest 3 (text "constructor: "  <+> ppr con)
    340 348 
             $$ nest 3 (text "sorted args: "  <+> ppr args)
    349 
    +        $$ nest 3 (text "non-ptrs (packed) size: " <+> int (fromIntegral nonPtrsSize) <+> text "words")
    341 350 
        ppr (ProtoBCO { protoBCOName       = name
    342 351 
                      , protoBCOInstrs     = instrs
    343 352 
                      , protoBCOBitmap     = bitmap

  • compiler/GHC/ByteCode/Types.hs
    ... ... @@ -262,7 +262,9 @@ data UnlinkedBCO
    262 262 
             -- confused with the name of the static constructor itself
    263 263 
             -- ('unlinkedStaticConDataConName')
    264 264 
             unlinkedStaticConDataConName :: !Name,
    265 
    -        unlinkedStaticConLits :: !(FlatBag BCONPtr), -- non-ptrs
    265 
    +        unlinkedStaticConLits :: !(FlatBag BCONPtr),
    266 
    +        -- ^ non-ptrs full words, where sub-word literals have already been
    267 
    +        -- packed into full words as needed
    266 268 
             unlinkedStaticConPtrs :: !(FlatBag BCOPtr),  -- ptrs
    267 269 
             unlinkedStaticConIsUnlifted :: !Bool
    268 270 
        }
    ... ... @@ -331,7 +333,7 @@ instance Outputable UnlinkedBCO where
    331 333 
           = sep [text "StaticCon", ppr nm, text "for",
    332 334 
                  if unl then text "unlifted" else text "lifted",
    333 335 
                  ppr dc_nm, text "with",
    334 
    -             ppr (sizeFlatBag lits), text "lits",
    336 
    +             ppr (sizeFlatBag lits), text "lits", parens (text "(packed) full words"),
    335 337 
                  ppr (sizeFlatBag ptrs), text "ptrs" ]
    336 338
    337 339 
     instance Binary FFIInfo where

  • compiler/GHC/StgToByteCode.hs
    ... ... @@ -304,16 +304,25 @@ schemeTopBind :: (Id, CgStgRhs) -> BcM ProtoBCO
    304 304 
     schemeTopBind (id, rhs@(StgRhsCon _ dc _ _ args _))
    305 305 
       = do
    306 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
    307 
    +    let
    308 
    +      non_voids = addArgReps (assertNonVoidStgArgs args)
    309 
    +      (tot_wds, --  #ptr_wds + #nonptr_wds
    310 
    +       ptr_wds, --  #ptr_wds
    311 
    +       nv_args_w_offsets) =
    312 
    +           -- Compute the runtime ordering for the datacon fields
    313 
    +           -- (Subword-sized fields are laid out contiguously, and padding is
    314 
    +           -- represented as literals of value 0 with the appropriate width)
    315 
    +           mkVirtHeapOffsetsWithPadding profile StdHeader non_voids
    316 
    +      contiguous_args_with_pad =
    317 
    +          litsWithPaddingToLits nv_args_w_offsets
    318 
    +
    311 319 
         return ProtoStaticCon
    312 320 
           { protoStaticConName = getName id
    313 321 
           , protoStaticCon     = dc
    314 322 
           , protoStaticConData = [ case a of StgLitArg l -> Left l
    315 323 
                                              StgVarArg i -> Right i
    316 
    -                             | (NonVoid a, _) <- args_offsets ]
    324 
    +                             | NonVoid a <- contiguous_args_with_pad ]
    325 
    +      , protoStaticConNonPtrsSize = tot_wds - ptr_wds
    317 326 
           , protoStaticConExpr = rhs
    318 327 
           }
    319 328 
     schemeTopBind (id, rhs)

  • compiler/GHC/StgToCmm/DataCon.hs
    ... ... @@ -100,23 +100,7 @@ cgTopRhsCon cfg id con mn args
    100 100 
                  nv_args_w_offsets) =
    101 101 
                      mkVirtHeapOffsetsWithPadding profile StdHeader (addArgReps args)
    102 102
    103 
    -        ; let
    104 
    -            -- Decompose padding into units of length 8, 4, 2, or 1 bytes to
    105 
    -            -- allow the implementation of mk_payload to use widthFromBytes,
    106 
    -            -- which only handles these cases.
    107 
    -            fix_padding (x@(Padding n off) : rest)
    108 
    -              | n == 0                 = fix_padding rest
    109 
    -              | n `elem` [1,2,4,8]     = x : fix_padding rest
    110 
    -              | testBit n 0            = add_pad 1
    111 
    -              | testBit n 1            = add_pad 2
    112 
    -              | testBit n 2            = add_pad 4
    113 
    -              | otherwise              = add_pad 8
    114 
    -              where add_pad m = Padding m off : fix_padding (Padding (n-m) (off+m) : rest)
    115 
    -            fix_padding (x : rest)     = x : fix_padding rest
    116 
    -            fix_padding []             = []
    117 
    -
    118 
    -            mk_payload (Padding len _) = return (CmmInt 0 (widthFromBytes len))
    119 
    -            mk_payload (FieldOff arg _) = do
    103 
    +            mk_payload arg = do
    120 104 
                     amode <- getArgAmode arg
    121 105 
                     case amode of
    122 106 
                       CmmLit lit -> return lit
    ... ... @@ -129,8 +113,7 @@ cgTopRhsCon cfg id con mn args
    129 113 
                  -- needs to poke around inside it.
    130 114 
                 info_tbl = mkDataConInfoTable profile con (addModuleLoc this_mod mn) True ptr_wds nonptr_wds
    131 115
    132 
    -
    133 
    -        ; payload <- mapM mk_payload (fix_padding nv_args_w_offsets)
    116 
    +        ; payload <- mapM mk_payload (litsWithPaddingToLits nv_args_w_offsets)
    134 117 
                     -- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs
    135 118 
                     -- NB2: all the amodes should be Lits!
    136 119 
                     --      TODO (osa): Why?

  • compiler/GHC/StgToCmm/Layout.hs
    ... ... @@ -23,6 +23,7 @@ module GHC.StgToCmm.Layout (
    23 23 
             mkVirtHeapOffsetsWithPadding,
    24 24 
             mkVirtConstrOffsets,
    25 25 
             mkVirtConstrSizes,
    26 
    +        litsWithPaddingToLits,
    26 27 
             getHpRelOffset,
    27 28
    28 29 
             ArgRep(..), toArgRep, toArgRepOrV, idArgRep, argRepSizeW, -- re-exported from GHC.StgToCmm.ArgRep
    ... ... @@ -66,6 +67,7 @@ import Control.Monad
    66 67 
     import GHC.StgToCmm.Config (stgToCmmPlatform)
    67 68 
     import GHC.StgToCmm.Types
    68 69 
     import Data.List.NonEmpty (nonEmpty)
    70 
    +import GHC.Types.Literal
    69 71
    70 72 
     ------------------------------------------------------------------------
    71 73 
     --                Call and return sequences
    ... ... @@ -423,6 +425,10 @@ data FieldOffOrPadding a
    423 425 
         | Padding ByteOff  -- Length of padding in bytes.
    424 426 
                   ByteOff  -- Offset in bytes.
    425 427
    428 
    +instance Outputable a => Outputable (FieldOffOrPadding a) where
    429 
    +    ppr (FieldOff (NonVoid a) off) = text "Field" <+> ppr a <+> text "at offset" <+> int off
    430 
    +    ppr (Padding size off) = text "Padding of size" <+> int size <+> text "at offset" <+> int off
    431 
    +
    426 432 
     -- | Used to tell the various @mkVirtHeapOffsets@ functions what kind
    427 433 
     -- of header the object has.  This will be accounted for in the
    428 434 
     -- offsets of the fields returned.
    ... ... @@ -512,6 +518,25 @@ mkVirtHeapOffsetsWithPadding profile header things =
    512 518 
                                  , field_off
    513 519 
                                  ]
    514 520
    521 
    +-- | Flatten a list of @'FieldOffOrPadding' StgArg@ into a list of @NonVoid StgArg@
    522 
    +-- by decompose padding into zero-valued 'StgLitArgs' units of length 8, 4, 2, or 1 bytes.
    523 
    +litsWithPaddingToLits :: [FieldOffOrPadding StgArg] -> [NonVoid StgArg]
    524 
    +litsWithPaddingToLits = concatMap $ \case
    525 
    +  FieldOff (NonVoid arg) _ -> [NonVoid arg]
    526 
    +  Padding size _ -> map (NonVoid . StgLitArg) (zeroBytes size)
    527 
    +  where
    528 
    +    -- Make literals of value 0 for a total of n bytes of padding.
    529 
    +    zeroBytes :: ByteOff -> [Literal]
    530 
    +    zeroBytes n
    531 
    +      | n == 0       = []
    532 
    +      | n == 1       = [LitNumber LitNumWord8  0]
    533 
    +      | n == 2       = [LitNumber LitNumWord16 0]
    534 
    +      | n == 4       = [LitNumber LitNumWord32 0]
    535 
    +      | n == 8       = [LitNumber LitNumWord64 0]
    536 
    +      | testBit n 0  = LitNumber LitNumWord8  0 : zeroBytes (n-1)
    537 
    +      | testBit n 1  = LitNumber LitNumWord16 0 : zeroBytes (n-2)
    538 
    +      | testBit n 2  = LitNumber LitNumWord32 0 : zeroBytes (n-4)
    539 
    +      | otherwise    = LitNumber LitNumWord64 0 : zeroBytes (n-8)
    515 540
    516 541 
     mkVirtHeapOffsets
    517 542 
       :: Profile

  • libraries/ghci/GHCi/ResolvedBCO.hs
    ... ... @@ -45,7 +45,7 @@ data ResolvedBCO
    45 45 
             resolvedBCOBitmap :: BCOByteArray Word,         -- ^ bitmap
    46 46 
             resolvedBCOLits   :: BCOByteArray Word,
    47 47 
               -- ^ non-ptrs - subword sized entries still take up a full (host) word
    48 
    -        resolvedBCOPtrs   :: (SizedSeq ResolvedBCOPtr)  -- ^ ptrs
    48 
    +        resolvedBCOPtrs   :: SizedSeq ResolvedBCOPtr  -- ^ ptrs
    49 49 
        }
    50 50 
        -- | A resolved static constructor
    51 51 
        -- See Note [Static constructors in Bytecode]
    ... ... @@ -53,7 +53,18 @@ data ResolvedBCO
    53 53 
             resolvedBCOIsLE          :: Bool,
    54 54 
             resolvedStaticConInfoPtr :: !(RemotePtr Heap.StgInfoTable),
    55 55 
             resolvedStaticConArity   :: {-# UNPACK #-} !Word,
    56 
    +        -- ^ how many words are used for the payload of the static constructor
    57 
    +        -- (size of ptrs and (packed) non-ptrs combined)
    56 58 
             resolvedStaticConLits    :: BCOByteArray Word,
    59 
    +        -- ^ Notably, sub-word non-ptr arguments and padding have already been
    60 
    +        -- packed into full words, and this array only stores the full final
    61 
    +        -- words to write as the constructor payload.
    62 
    +        --
    63 
    +        -- This is opposed to what we do for BCO literals, where we keep
    64 
    +        -- sub-word literals as full words. For static constructors, the layout
    65 
    +        -- must match exactly what the NCG also expects, so we must pack
    66 
    +        -- sub-words accordingly for compatibility between interpreted and
    67 
    +        -- compiled code.
    57 68 
             resolvedStaticConPtrs    :: SizedSeq ResolvedBCOPtr,
    58 69 
             resolvedStaticConIsUnlifted :: Bool
    59 70 
        }

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